packages feed

lattest-lib (empty) → 0.1.0.0

raw patch · 49 files changed

+9668/−0 lines, 49 filesdep +HUnitdep +MissingHdep +QuickChecksetup-changed

Dependencies added: HUnit, MissingH, QuickCheck, aeson, attoparsec, attoparsec-aeson, base, bytestring, cassava, containers, either, extra, io-streams, lattest-lib, lattices, list-shuffle, mtl, network, parallel, random, raw-strings-qq, sbv, scientific, stm, tasty, tasty-quickcheck, text, time, unbounded-delays

Files

+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog for `lattest-lib`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - 2026-07-14+First release+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ramon Janssen (c) 2025++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lattest-lib.cabal view
@@ -0,0 +1,140 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name:           lattest-lib+version:        0.1.0.0+synopsis:       Model-based testing framework+description:    Welcome to Lattest, the latest attested lattice testing tech!+                .+                The purpose of Lattest to assist in model-based testing: set up a test for external systems, where the expected behaviour of that system+                is expressed as a specification model in the form of an automaton.+                .+                For details on setting up such a test, see "Lattest.Exec.Testing"+category:       Testing+homepage:       https://github.com/ramon-janssen/lattest+author:         Ramon Janssen+maintainer:     David van Balen+copyright:      2023 Ramon Janssen+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGELOG.md++library+  exposed-modules:+      Data.OrdMonad+      Lattest.Adapter.Adapter+      Lattest.Adapter.StandardAdapters+      Lattest.Exec.ADG.Aut+      Lattest.Exec.ADG.DistGraph+      Lattest.Exec.ADG.SplitGraph+      Lattest.Exec.StandardTestControllers+      Lattest.Exec.StandardTestControllers.CompleteTestSuite+      Lattest.Exec.Testing+      Lattest.Model.Alphabet+      Lattest.Model.Automaton+      Lattest.Model.BoundedMonad+      Lattest.Model.StandardAutomata+      Lattest.Model.Symbolic.Expr+      Lattest.Model.Symbolic.Internal.ExprDefs+      Lattest.Model.Symbolic.Internal.FreeMonoidX+      Lattest.Model.Symbolic.SolveSymPrim+      Lattest.SMT+      Lattest.Streams.Synchronized+      Lattest.Streams.Synchronized.Attoparsec+      Lattest.Util.ModelParsingUtils+      Lattest.Util.ReportUtils+      Lattest.Util.STSJSONParser+      Lattest.Util.Utils+  other-modules:+      Lattest.Model.Internal.NonDeterministic+      Lattest.Model.Symbolic.Internal.Boute+      Lattest.Model.Symbolic.Internal.ExprImpls+      Lattest.Model.Symbolic.Internal.ExprImplsExtension+      Lattest.Model.Symbolic.Internal.Product+      Lattest.Model.Symbolic.Internal.Sum+      Lattest.Model.Symbolic.SolveSTS+      Lattest.Util.IOUtils+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints -Wno-simplifiable-class-constraints -Wno-unused-top-binds -Wno-orphans+  build-depends:+      MissingH >=1.6.0 && <1.7+    , aeson >=2.2.3.0 && <2.4+    , attoparsec >=0.14.4 && <0.15+    , attoparsec-aeson >=2.2.2 && <2.3+    , base >=4.19.2 && <4.22+    , bytestring >=0.12.1 && <0.13+    , cassava >=0.5.3.2 && <0.6+    , containers >=0.6.8 && <0.8+    , either >=5.0.2 && <5.1+    , extra >=1.7.16 && <1.9+    , io-streams >=1.5.2 && <1.6+    , list-shuffle >=1.0.0 && <1.1+    , mtl >=2.3.1 && <2.4+    , network >=3.2.7.0 && <3.3+    , parallel >=3.2.2.0 && <3.4+    , random >=1.2.1.3 && <1.4+    , sbv >=11.0 && <15+    , scientific >=0.3.8 && <0.4+    , stm >=2.5.3 && <2.6+    , text >=2.1.1 && <2.2+    , time >=1.12.2 && <1.15+    , unbounded-delays >=0.1.1 && <0.2+  default-language: Haskell2010++test-suite lattest-test+  type: exitcode-stdio-1.0+  main-is: Test.hs+  other-modules:+      Reference.FreeLatticeSlow+      Test.Lattest.Adapter.StandardAdapters+      Test.Lattest.Exec.NComplete+      Test.Lattest.Exec.StandardTestControllers+      Test.Lattest.Exec.Testing+      Test.Lattest.Model.BoundedMonad+      Test.Lattest.Model.StandardAutomata+      Test.Lattest.Model.STSTest+      Test.Lattest.Model.Symbolic.Expr+      Test.Lattest.Util.ModelParsingUtils+      Test.Lattest.Util.STSJSONParserTest+      Test.System.IO.Streams.Synchronized+      Paths_lattest_lib+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints -Wno-simplifiable-class-constraints -Wno-unused-top-binds -Wno-orphans -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit >=1.6.2.0+    , MissingH >=1.6.0 && <1.7+    , QuickCheck >=2.15.0.1+    , aeson >=2.2.3.0 && <2.4+    , attoparsec >=0.14.4 && <0.15+    , attoparsec-aeson >=2.2.2 && <2.3+    , base >=4.19.2 && <4.22+    , bytestring >=0.12.1 && <0.13+    , cassava >=0.5.3.2 && <0.6+    , containers >=0.6.8 && <0.8+    , either >=5.0.2 && <5.1+    , extra >=1.7.16 && <1.9+    , io-streams >=1.5.2 && <1.6+    , lattest-lib+    , lattices >=2.2.1 && <2.3+    , list-shuffle >=1.0.0 && <1.1+    , mtl >=2.3.1 && <2.4+    , network >=3.2.7.0 && <3.3+    , parallel >=3.2.2.0 && <3.4+    , random >=1.2.1.3 && <1.4+    , raw-strings-qq ==1.1.*+    , sbv >=11.0 && <15+    , scientific >=0.3.8 && <0.4+    , stm >=2.5.3 && <2.6+    , tasty >=1.5.3+    , tasty-quickcheck+    , text >=2.1.1 && <2.2+    , time >=1.12.2 && <1.15+    , unbounded-delays >=0.1.1 && <0.2+  default-language: Haskell2010
+ src/Data/OrdMonad.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+    A simple implementation of 'Functor' and 'Monad' with 'Ord' constraints, to make operations on those data types more efficient.+-}++module Data.OrdMonad (+-- * Functors, Monads, and Traversables with Ordering+-- ** Functors with ordering+OrdFunctor,+ordMap,+(<#>),+-- ** Monads with ordering+OrdMonad,+ordBind,+ordReturn,+ordJoin,+-- ** Traversables with ordering+OrdTraversable(..)+)+where++import qualified Data.Set as Set++{-|+    Functors with an additional 'Ord' constraint. The primary use case for the 'OrdFunctor' is to treat data structures like 'Set' as a functor, where the 'Ord'-constraint is used for performance reasons.+    Implementations of 'ordMap' should adhere to the same laws as for 'fmap' for a @'Functor' F@:++    [Identity]    @'ordMap' 'id' == 'id'@+    [Composition] @'ordMap' (f . g) == 'ordMap' f . 'ordMap' g@++    The composition law is only required if the extensionality property of type class 'Eq' holds for the domain of @f@. Effectively, this states+    that 'Eq' should behave like proper equality for @f@, or conversely, if @x '==' y@ and @f x '/=' f y@, then compositionality is not expected to hold.+-}+class OrdFunctor f where+    -- | Map a function over a functorial type, just like 'fmap', but with an additional 'Ord' constraint.+    ordMap :: (Ord b) => (a -> b) -> f a -> f b++-- | An infix synonym for 'ordMap', similar to '<$>'.+(<#>) :: (OrdFunctor f, Ord b) => (a -> b) -> f a -> f b+(<#>) = ordMap++-- | Any 'Functor' is also an 'OrdFunctor', ignoring the 'Ord' constraint..+instance {-# OVERLAPPABLE #-} Functor f => OrdFunctor f where+    ordMap = fmap++{-|+    Monads with an additional 'Ord' constraint. Analogously to how an 'OrdFunctor' specializes a regular 'Functor', 'OrdMonad' uses the 'Ord'-constraint is used for performance reasons.+    Any instance should adhere to the 'Monad' laws, assuming the extensionality property for equality 'Eq'. See 'OrdFunctor' for details.+-}+class (OrdFunctor m) => OrdMonad m where+    -- | Return operation, similar to the standard monadic 'return'. No 'Ord' constraint is present here, as comparing values is not needed for injecting a single value into a monadic type.+    ordReturn :: a -> m a+    -- | Bind operation, using an 'Ord' constraint, similar to the standard monadic bind operation '>>='.+    ordBind :: (Ord b) => m a -> (a -> m b) -> m b++-- | Any 'Monad' is also an 'OrdMonad', ignoring the 'Ord' constraint.+instance {-# OVERLAPPABLE #-} Monad m => OrdMonad m where+    ordBind = (>>=)+    ordReturn = return++-- | Standard monadic 'join', but with an additional 'Ord' constraint.+ordJoin :: (Ord a, OrdMonad m) => m (m a) -> m a+ordJoin mma = ordBind mma id++-- |Traversable with additional 'Ord' constraints.+class (OrdFunctor t, Foldable t) => OrdTraversable t where+    {-# MINIMAL ordTraverse, ordSequenceA #-}++    -- | Map each element of a structure to an action, evaluate these actions+    -- from left to right, and collect the results.+    ordTraverse :: (Applicative f, Ord b) => (a -> f b) -> t a -> f (t b)++    -- | Evaluate each action in the structure from left to right, and+    -- collect the results.+    ordSequenceA :: (Applicative f, Ord a) => t (f a) -> f (t a)++    -- | Map each element of a structure to a monadic action, evaluate+    -- these actions from left to right, and collect the results.+    ordMapM :: (Monad m, Ord b) => (a -> m b) -> t a -> m (t b)+    ordMapM = ordTraverse++    -- | Evaluate each monadic action in the structure from left to+    -- right, and collect the results.+    ordSequence :: (Monad m, Ord a) => t (m a) -> m (t a)+    ordSequence = ordSequenceA++instance {-# OVERLAPPABLE #-} (Foldable t, Traversable t) => OrdTraversable t where+  ordTraverse = traverse+  ordSequenceA = sequenceA++-- | 'Set' is the the prototypical 'OrdFunctor' instance. It maps a function over the set elements, deduplicating the results.+instance OrdFunctor Set.Set where+    ordMap = Set.map++-- | 'Set' is the the prototypical 'OrdMonad' instance, where @s \`'ordBind'\` f@ is the set \( \{ x \in s' \mid s' \in f[s] \} \).+instance OrdMonad Set.Set where+    ordBind s f = Set.unions $ Set.map f s+    ordReturn = Set.singleton++-- | 'Set' is the prototypical 'OrdTraversable' instance.+instance OrdTraversable Set.Set where+    ordSequenceA = foldr (\x xs -> Set.insert <$> x <*> xs) $ pure Set.empty+    ordTraverse f = fmap Set.fromList . traverse f . Set.toList+
+ src/Lattest/Adapter/Adapter.hs view
@@ -0,0 +1,113 @@+module Lattest.Adapter.Adapter (+-- * Definition+Adapter(..),+-- * Interaction +send,+observe,+tryObserve,+-- * Transformations+map,+mapTestChoices,+mapActionsFromSut,+parseActionsFromSut+)+where++import Prelude hiding (map)++import Control.Monad.STM(atomically)+import Data.Attoparsec.ByteString(Parser)+import Data.ByteString(ByteString)+import System.IO.Streams (OutputStream)+import System.IO.Streams.Combinators(contramap)+import Lattest.Streams.Synchronized(TInputStream, tryReadIO, Streamed)+import Lattest.Streams.Synchronized.Attoparsec (parserToInputStream)+import qualified System.IO.Streams as Streams (write)+import qualified Lattest.Streams.Synchronized as Streams (map,read)++-- | An adapter to a (usually external) system. Uses two channels for interaction: one to send input commands, and one to receive outputs.+data Adapter act i = Adapter {+    inputCommandsToSut :: OutputStream i, -- ^ Channel for sending input commands.+    actionsFromSut :: TInputStream act, -- ^ Channel for receiving outputs.+    +    -- TODO should calling close somehow also automatically send a Nothing to the inputCommandsToSut?+    close :: IO () -- ^ Close the (channels of this) adapter.+    }++{-instance AbstractAdapter BlockingAdapter where+    inputCommandsToSut = blockingTestChoicesToSut+    actionsFromSut = blockingActionsFromSut+    unblockedActionsFromSut adap = do+        unblockedActions <- forkEagerInputStream $ blockingActionsFromSut adap+        return $ Adapter {+            readyTestChoicesToSut = blockingTestChoicesToSut adap,+            readyActionsFromSut = unblockedActions,+            readyClose = close adap+        }+    close = blockingClose+-}++{-|+    Try to observe, without blocking, with three possible outcomes:++    * An observation is made,+    * no observation was ready, so no observation was made but another attempt may make an observation,+    * The stream has closed, and any further attempts will give the same result.+-}+tryObserve :: Adapter act i -> IO (Streamed act)+tryObserve = tryReadIO . actionsFromSut++-- | Send an input to the adapter.+send :: i -> Adapter act i -> IO ()+send i adap = Streams.write (Just i) (inputCommandsToSut adap)++{-|+    Observe in a blocking manner, with two possible outcomes:++    * An observation is made,+    * The stream has closed, and any further attempts will give the same result.+-}+observe :: Adapter act i -> IO (Maybe act) -- TODO get rid of the maybe+observe = atomically . Streams.read . actionsFromSut++--------------------+-- transformations --+---------------------++-- | Map a function over the inputs sent to the adapter.+mapTestChoices :: (i' -> i) -> Adapter act i -> IO (Adapter act i')+mapTestChoices f adapter = do+    inputCommandsToSut' <- contramap f $ inputCommandsToSut adapter+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut',+        actionsFromSut = actionsFromSut adapter,+        close = close adapter+        }++-- | Map a function over the outputs received from the adapter.+mapActionsFromSut :: (act -> act') -> Adapter act i -> IO (Adapter act' i)+mapActionsFromSut f adapter = do+    actionsFromSut' <- Streams.map f $ actionsFromSut adapter+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut adapter,+        actionsFromSut = actionsFromSut',+        close = close adapter+        }++-- | Map function over both the inputs sent to, and the outputs received from, the adapter.+map :: (i' -> i) -> (act -> act') -> Adapter act i -> IO (Adapter act' i')+map f1 f2 adapter = do+    inputCommandsToSut' <- contramap f1 $ inputCommandsToSut adapter+    actionsFromSut' <- Streams.map f2 $ actionsFromSut adapter+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut',+        actionsFromSut = actionsFromSut',+        close = close adapter+        }++-- | Transform a raw adapter which receives ByteStrings to an adapter which receives objects, parsing the bytestrings with the given parser.+parseActionsFromSut :: Parser act -> Adapter ByteString i -> IO (Adapter act i)+parseActionsFromSut parser adapter = do+    actionStream <- parserToInputStream (Just <$> parser) (actionsFromSut adapter)+    return $ adapter { actionsFromSut = actionStream }+
+ src/Lattest/Adapter/StandardAdapters.hs view
@@ -0,0 +1,605 @@+{- |+    This module contains building blocks for constructing out-of-the-box 'Adapter's.++    Note that adapters do not observe inputs by default. In other words, an input command+    from a test controller does not automatically lead to an input transition in the specification+    model. Use 'acceptingInputs' to observe all sent inputs, or 'acceptingInputsWithIncompletenessAsFailures'+    to also observe failures in processing inputs in the adapter. The latter is useful if the processing+    of inputs is defined partially, in which case some inputs cannot be sent to the adapter.+-}++-- TODO also expose a generic parsing transformation which takes a parser+module Lattest.Adapter.StandardAdapters (+-- * Type Definition+Adapter, -- re-export so that a user of the library who wants to set up a testing experiment doesn't need to import the Adapter module at all+-- * Ready-to-use Adapters+-- ** Pure adapters+-- | Adapters which are defined in haskell itself.+pureMealyAdapter,+pureAdapter,+-- ** Socket Adapters+-- *** Settings+SocketSettings(..),+baseSocketSettings,+-- *** Base Socket Adapters+connectSocketAdapter,+connectSocketAdapterWith,+-- *** Socket Adapters with JSON+connectJSONSocketAdapter,+connectJSONSocketAdapterWith,+connectJSONSocketAdapterAcceptingInputs,+connectJSONSocketAdapterAcceptingInputsWith,+-- * Transformations on Adapters+-- ** Encoding and Decoding+encodeUtf8,+decodeUtf8,+endecodeUtf8,+encodeJSONTestChoices,+parseJSONActionsFromSut,+-- ** Observing Inputs+acceptingInputs,+acceptingInputsWithIncompletenessAsFailures,+-- ** Timing and Quiescence+withQuiescence,+withQuiescenceMillis,+withInputDelay,+withInputDelayMillis,+withSuccessiveInputDelay,+withSuccessiveInputDelayMillis,+-- ** Adapters with Data Parameters+asSymbolicSuspAdapter,+connectJSONSocketAdapterSTSwithQuiescence+)+where++import Lattest.Adapter.Adapter as Adap (Adapter(..),parseActionsFromSut,mapTestChoices,mapActionsFromSut, map)+import Lattest.Model.Alphabet(TestChoice, choiceToActs, IOAct(..), Suspended(..), IOSuspAct, asSuspended, IOSuspGateValue, GateValue(..), SuspendedIF, isOutput, fromOutput, IFAct, InputAttempt(..))+import Lattest.Util.IOUtils(statefulIO', doAfter, ifM_, waitUntil)+import Lattest.Util.Utils(flipCoin, takeRandom)++import Control.Concurrent.STM.TMVar(newEmptyTMVarIO, tryReadTMVar, writeTMVar, readTMVar, isEmptyTMVar, putTMVar)+import Control.Concurrent.STM.TQueue(newTQueueIO, readTQueue, writeTQueue, isEmptyTQueue)+import Control.Concurrent.Thread.Delay(delay)+import Control.Exception(handle,PatternMatchFail)+import Control.Monad(forever,void)+import Control.Monad.Extra ((||^), (&&^))++import Data.Aeson(fromJSON,encode,Result(Error, Success), FromJSON, ToJSON)+import Data.Aeson.Parser(jsonNoDup)+import Data.Bits.Utils(c2w8)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy(toStrict,snoc)+import Data.List(singleton)+import Data.Time.Clock(getCurrentTime,addUTCTime,diffUTCTime,NominalDiffTime,secondsToNominalDiffTime,nominalDiffTimeToSeconds)++import Debug.Trace(trace) -- FIXME find a better alternative++import GHC.Conc(forkIO, newTVarIO, TVar, retry, atomically, writeTVar, readTVar, STM, orElse)++import Network.Socket(HostName, PortNumber)+import Network.Utils (niceSocketsDo, connectTCP)++import System.IO.Streams as Streams (makeOutputStream, OutputStream, write, writeTo)+import System.IO.Streams.Combinators(contramap)+import System.IO.Streams.Network(socketToStreams)+import Lattest.Streams.Synchronized(TInputStream, duplicate, fromBuffer, mergeBufferedWith, mapUnbuffered, fromTMVar, readAll, fromInputStreamBuffered, makeTInputStream, hasInput)+import qualified Lattest.Streams.Synchronized as Streams (read, unRead)+import System.Random(RandomGen)++import qualified Data.Attoparsec.ByteString.Char8 as Parse+import qualified Data.Map as Map (Map, filterWithKey, null, lookup, toList)+import qualified Data.Text as Text (pack, unpack)+import qualified Data.Text.Encoding as Encoding (decodeUtf8With, encodeUtf8)+import qualified Data.Text.Encoding.Error as Encoding (lenientDecode)+import qualified Network.Socket as Socket(gracefulClose)++-- | Take an adapter that sends raw 'ByteString's, and transform it to an adapter that sends 'String's encoded in utf-8.+encodeUtf8 :: Adapter act ByteString -> IO (Adapter act String)+encodeUtf8 = mapTestChoices $ Encoding.encodeUtf8 . Text.pack++-- | Take an adapter that receives raw 'ByteString's, and transform it to an adapter that receives 'String's decoded from utf-8.+decodeUtf8 :: Adapter ByteString i -> IO (Adapter String i)+decodeUtf8 = mapActionsFromSut $ Text.unpack . Encoding.decodeUtf8With Encoding.lenientDecode++-- | Take an adapter that sends and receives raw 'ByteString's, and transform it to an adapter that sends and receives 'String's, encoded in utf-8 and decoded from utf-8.+endecodeUtf8 :: Adapter ByteString ByteString -> IO (Adapter String String)+endecodeUtf8 = Adap.map (Encoding.encodeUtf8 . Text.pack) (Text.unpack . Encoding.decodeUtf8With Encoding.lenientDecode)++encodeJSON :: (ToJSON i) => i -> ByteString+encodeJSON = toStrict . flip snoc (c2w8 '\n') . encode -- encode as strict ByteString and append a newline as separator++-- | Take an adapter that sends raw 'ByteString's, and transform it to an adapter that sends any type encoded in JSON.+encodeJSONTestChoices :: (ToJSON i) => Adapter act ByteString -> IO (Adapter act i)+encodeJSONTestChoices = mapTestChoices encodeJSON++-- | Take an adapter that receives raw 'ByteString's, and transform it to an adapter that receives any type decoded from JSON.+parseJSONActionsFromSut :: (FromJSON act) => Adapter ByteString i -> IO (Adapter act i)+parseJSONActionsFromSut adap = do+    valueAdap <- parseActionsFromSut (Parse.skipSpace *> jsonNoDup) adap+    mapActionsFromSut (fromResult . fromJSON) valueAdap+    where+    fromResult (Success s) = s+    fromResult (Error e) = Debug.Trace.trace e $ undefined e -- TODO handle error case++-- transform an adapter to transfer input commands to observed actions+--+-- architecture:+-- input--combinedInputOS---fduplicate---adapInputOS---\+--                                \                     \+--                                |                      \+--                       loopbackInputOS                 |+--                                v                      v+--                       loopbackActionOS             +------++--                       [loopbackBuffer]             | adap |+--                       loopbackActionIS             +------++--                                |                      |+--                                v                      |+-- <--output--combinedActionIS--fmerge <--adapActionIS---/+loopbackAdapter ::+    Adapter o ic+    -> (OutputStream i -> OutputStream ic -> IO (OutputStream ic))+    -> (TInputStream (IOAct i o) -> TInputStream (IOAct i o) -> IO (TInputStream (IOAct i o)))+    -> IO (Adapter (IOAct i o) ic)+loopbackAdapter adap fduplicate fmerge = do+    loopbackBuffer <- newEmptyTMVarIO++    loopbackActionOS <- makeOutputStream $ atomically . putTMVar loopbackBuffer+    loopbackInputOS <- actionToInputOS loopbackActionOS -- map type i to type IOAct i o+    let adapInputOS = inputCommandsToSut adap+    combinedInputOS <- fduplicate loopbackInputOS adapInputOS++    loopbackActionIS <- fromTMVar loopbackBuffer+    let adapActionIS = outputToActionIS adap -- map type o to IOAct i o+    -- loopback first: in case of a quick response to an input, the merging thread may see the input and output at the same time.+    combinedActionIS <- fmerge loopbackActionIS adapActionIS -- the merge buffer lives in here implicitly++    return $ Adapter {+        inputCommandsToSut = combinedInputOS,+        actionsFromSut = combinedActionIS,+        close = close adap+        }++outputToActionIS :: Adapter a i1 -> TInputStream (IOAct i2 a)+outputToActionIS adap = mapUnbuffered Out (error "acceptingInputs buffer from SUT does not support pushback") (actionsFromSut adap)+actionToInputOS :: TestChoice a1 a2 => OutputStream a2 -> IO (OutputStream a1)+actionToInputOS actionOS = streamSequence actionOS >>= contramap choiceToActs+-- direct pushbacks to the streams below is not needed, the merge buffer will handle pushbacks instead+streamSequence :: OutputStream a -> IO (OutputStream [a])+streamSequence s = makeOutputStream $ doMaybeSequenceCmd $ Streams.writeTo s+doMaybeSequenceCmd :: (Maybe a -> IO ()) -> Maybe [a] -> IO ()+doMaybeSequenceCmd writeMaybeAct Nothing = writeMaybeAct Nothing+doMaybeSequenceCmd writeMaybeAct (Just xs) = mapM_ (writeMaybeAct . Just) xs++{- |+    Transform a given Adapter to accept all inputs. In other words, every selected input command directly becomes an observed input action.+    Every observed output from the given Adapter becomes an output action.+-}+acceptingInputs :: Adapter o i -> IO (Adapter (IOAct i o) i)+acceptingInputs adap = loopbackAdapter adap duplicate (mergeBufferedWith mergeActions)+-- merging is done by reading an input, followed by all outputs that are then available. If no input is available, then read an output instead+mergeActions :: TInputStream (IOAct i o) -> TInputStream (IOAct i o) -> STM [Maybe (IOAct i o)]+mergeActions loopbackActionIS adapActionIS = do+    hasLoopbackAction <- hasInput loopbackActionIS+    if hasLoopbackAction+        then do+            inp <- Streams.read loopbackActionIS+            outs <- readAll adapActionIS+            return (inp:outs)+        else do+            hasAdapAction <- hasInput adapActionIS+            if hasAdapAction+                then singleton <$> Streams.read adapActionIS+                else retry++{- |+    Transform a given Adapter to accept all inputs, but if the given Adapter would call an undefined case in a partial function, then interpret this+    as an observed input failure. Any input command that does not call undefined cases of partial functions directly become observed input action.+    Every observed output from the given Adapter becomes an output action.++    Input failures are useful for Adapters written in pure haskell. Instead of only writing complete functions to process input commands, where unexpected+    input commands may e.g. lead to an error output, the adapter may also just process input commands with partial functions instead, avoiding some boilerplate code.+-}+acceptingInputsWithIncompletenessAsFailures :: Adapter o i -> IO (Adapter (IFAct i o) i)+acceptingInputsWithIncompletenessAsFailures adap = do+    blockAdapActionsTVar <- newTVarIO False -- during duplication, block observation of actions from the adapter+    loopbackAdapter adap (duplicateHandlingIncompleteness blockAdapActionsTVar) (mergeBufferedWith $ mergeActionsPaused blockAdapActionsTVar)+    where+    mergeActionsPaused :: TVar Bool -> TInputStream (IOAct i o) -> TInputStream (IOAct i o) -> STM [Maybe (IOAct i o)]+    mergeActionsPaused blockAdapActionsTVar loopbackActionIS adapActionIS = do+        blockAdapActions <- readTVar blockAdapActionsTVar+        if blockAdapActions+            then singleton <$> Streams.read loopbackActionIS -- adap actions are blocked, so observe just the loopback actions+            else mergeActions loopbackActionIS adapActionIS -- adap actions are not blocked, merge actions as normal+    duplicateHandlingIncompleteness :: TVar Bool -> OutputStream (InputAttempt i) -> OutputStream i -> IO (OutputStream i)+    duplicateHandlingIncompleteness isAdapOutputBlocked loopbackInputOS adapInputOS = makeOutputStream $ \mi -> do+        case mi of+            Nothing -> Streams.write Nothing loopbackInputOS >> Streams.write Nothing adapInputOS+            Just i -> do+                atomically $ writeTVar isAdapOutputBlocked True+                inputSucceeded <- attemptInputToAdap adapInputOS i+                let mInputAction = Just $ InputAttempt (i,inputSucceeded)+                Streams.write mInputAction loopbackInputOS+                atomically $ writeTVar isAdapOutputBlocked False+    attemptInputToAdap :: OutputStream i -> i -> IO Bool+    attemptInputToAdap adapInputOS i = handle (patternMatchHandler i) (Streams.write (Just i) adapInputOS >> return True)+    patternMatchHandler :: i -> PatternMatchFail -> IO Bool+    patternMatchHandler _ _ = return False+++-- | adapter which, after every input, directly sends the corresponding sequence of outputs+pureMealyAdapter :: (state -> i -> state) -> (state -> i -> [act]) -> state -> IO (Adapter act i)+-- FIXME this should also implicitly observe the accepted inputs, for which it probably needs to send either (IOAct i o) or (i/o) instead of an abstract act+pureMealyAdapter transitionFunction outputFunction initialState = do+    stateVar <- newTVarIO initialState+    outputQueue <- newTQueueIO+    is <- fromBuffer outputQueue+    os <- makeOutputStream $ \mi -> do+        case mi of+            Nothing -> do+                atomically $ writeTQueue outputQueue Nothing+            Just i -> do+                os <- transduce stateVar i+                atomically $ mapM_ (writeTQueue outputQueue . Just) os+    return $ Adapter {+        inputCommandsToSut = os,+        actionsFromSut = is,+        close = return ()+    }+    where+    transduce stateVar i = atomically $ do+        q <- readTVar stateVar+        writeTVar stateVar (transitionFunction q i)+        return $ outputFunction q i++{-|+    Adapter which, after every action, has the given probability of producing non-deterministically one of the corresponding (non-timeout) output transitions if any is available.+    After receiving a Nothing input, an output will be produced, which may be a timeout.+-}+pureAdapter :: (Ord i, Ord o, RandomGen g) => g -> Double -> (state -> Map.Map (IOAct i o) state) -> state -> IO (Adapter (SuspendedIF i o) (Maybe i))+pureAdapter g p transitionFunction initialState = do+    let ((g',q), outs) = randomOutputTransitions transitionFunction g initialState False -- immediately take some outputs at the start+    statefulAdapter <- statefulIO' (processInput transitionFunction) (g', q)+    queue <- newTQueueIO+    atomically $ mapM_ (writeTQueue queue . Just) outs+    inputStream <- fromBuffer queue+    outputStream <- makeOutputStream $ \mi -> do+        case mi of+            Nothing -> do+                atomically $ writeTQueue queue Nothing+            Just i -> do+                os <- statefulAdapter i+                atomically $ mapM_ (writeTQueue queue . Just) os+    return $ Adapter {+        inputCommandsToSut = outputStream,+        actionsFromSut = inputStream,+        close = return ()+    }+    where+        --processInput :: (Ord i, Ord o, RandomGen g) => (q -> Map.Map (IOAct i o) q) -> (g, q) -> Maybe i -> ((g, q), [Suspended o])+        processInput t (g', q) Nothing = randomOutputTransitions t g' q True+        processInput t (g', q) (Just i) = case Map.lookup (In i) (t q) of+            Just q' -> prependInput (InputAttempt (i, True)) $ randomOutputTransitions t g' q' False+            Nothing -> ((g', q), [In $ InputAttempt (i, False)])+        --randomOutputTransitions :: RandomGen g => (q -> Map.Map (IOAct i o) q) -> g -> q -> Bool -> ((g, q), [Suspended o])+        randomOutputTransitions t g'' q isAfterNoInput = let (g', q', outs) = randomOutputTransitions' t g'' q [] isAfterNoInput in ((g', q'), reverse outs)+        --randomOutputTransitions' :: RandomGen g => (q -> Map.Map (IOAct i o) q) -> g -> q -> [Suspended o] -> Bool -> (g, q, [Suspended o])+        randomOutputTransitions' t g''' q outs isAfterNoInput =+            let ts = Map.filterWithKey (\k _ -> isOutput k) (t q)+            in if Map.null ts -- if no outputs are available at all,+                then if isAfterNoInput then (g''', q, Out Quiescence : outs) else (g''', q, outs) -- then stop producing actions (meaning a timeout or just no more actions, depending on whether a "Nothing" input was previously received)+                else let (produceOut, g') = if isAfterNoInput then (True, g''') else flipCoin g''' p -- else decide whether to produce more actions. This is mandatory if a "Nothing" input was previously received, otherwise flip a coin+                    in if not produceOut+                        then (g', q, outs)+                        else -- pick a random output, and continue randomly picking more outputs+                            let ((o, q'), g'') = takeRandom  g' $ Map.toList ts+                            in randomOutputTransitions' t g'' q' (Out (OutSusp $ fromOutput o) : outs) False+        prependInput i (q, acts) = (q, In i:acts)++-- |  Transform the given Adapter by introducing quiescence (timeout observations). See 'withQuiescence', where the waiting time given in milliseconds.+withQuiescenceMillis :: Int -> Adapter (IOAct i o) i -> IO (Adapter (IOSuspAct i o) (Maybe i))+withQuiescenceMillis timeoutMillis = withQuiescence $ secondsToNominalDiffTime $ 0.001 * realToFrac timeoutMillis++{-|+    Transform the given Adapter by introducing quiescence (timeout observations). Inputs can be sent as 'Just' inputs, and 'IOAct' observations can be+    done as in the provided adapter, where the outputs in the 'IOAct' are wrapped in 'SuspAct' to denote that they are real outputs. Additionally:+    +    * An artificial 'Quiescence' output observation is made after the provided timeout value. This timeout is measured since the last 'Just' input or+    'SuspOut' output has been received.+    +    * An artificial 'Nothing' input can be made, which indicates waiting for an output. Sending a 'Nothing' will block until any output is received,+    which may be a real 'SuspAct' output or 'Quiescence'. This is guaranteed to happen within the given timeout value, give or take a few milliseconds+    for processing.+-}+withQuiescence :: NominalDiffTime -> Adapter (IOAct i o) i -> IO (Adapter (IOSuspAct i o) (Maybe i))+withQuiescence timeoutDiff adap = do+    lastObservationTime <- newEmptyTMVarIO -- time of the last observed action. Nothing if observing hasn't started yet.+    isProcessingObservation <- newTVarIO False+    observedQueue <- newTQueueIO+    let ensureObservationTime = do -- start observing, if this hasn't already been done yet+            isEmpty <- atomically $ isEmptyTMVar lastObservationTime+            ifM_ isEmpty $ do+                currentTime <- getCurrentTime+                atomically $ writeTMVar lastObservationTime currentTime+        updateObservationTime currentTime = do -- if the current time is past the stored observation time, then update that observation time to now+            mLastTime <- tryReadTMVar lastObservationTime+            case mLastTime of+                Nothing -> writeTMVar lastObservationTime currentTime+                Just lastTime -> ifM_ (lastTime < currentTime) $ writeTMVar lastObservationTime currentTime+        getWaitTimeMicros currentTime = do -- the number of microseconds until the target timeout is reached+            lastTime <- readTMVar lastObservationTime -- blocking, in case of Nothing+            let targetTime = addUTCTime timeoutDiff lastTime+                currentTime' = max currentTime lastTime -- lastTime > currentTime can occur if the caller waited too long after retrieving the+                                                        -- currentTime, in particular when blocking on reading lastObservationTime+            return $ ceiling $ 1000000 * nominalDiffTimeToSeconds (diffUTCTime targetTime currentTime')+        waitUntilQuiescence = do -- wait until the target timeout. Blocks if there is no target timeout yet.+            currentTime <- getCurrentTime+            waitTimeMicros <- atomically $ getWaitTimeMicros currentTime+            delay waitTimeMicros+        quiescenceMonitor = forever $ do -- background task that first wait until action monitoring starts, then continuously waits until a timeout+                                         -- is reached and sets the quiescence state to true+            waitUntilQuiescence+            currentTime <- getCurrentTime+            --quiIsSet <- atomically $ do+            atomically $ do+                additionalWaitTime <- getWaitTimeMicros currentTime+                let quiescent = additionalWaitTime <= (0 :: Int)+                ifM_ quiescent $ do+                    writeTQueue observedQueue (Just $ Out Quiescence)+                    updateObservationTime currentTime+        actMonitor = do --background task that waits for outputs, updates the observation time and unsets the quiescence state+            mAct <- atomically $ do+                writeTVar isProcessingObservation True+                Streams.read $ actionsFromSut adap+            currentTime <- getCurrentTime+            continue <- atomically $ do+                -- observation has been made+                updateObservationTime currentTime -- update the observation time+                writeTVar isProcessingObservation False+                case mAct of+                    Nothing -> do+                        writeTQueue observedQueue Nothing -- action adapter closed, pass on the Nothing once and then stop+                        return False+                    Just act -> do+                        writeTQueue observedQueue $ Just $ asSuspended act -- pass the action to the timeout adapter+                        return True+            ifM_ continue actMonitor -- repeat until close+        hasObservation = readTVar isProcessingObservation ||^ (not <$> isEmptyTQueue observedQueue) ||^ hasInput (actionsFromSut adap)+    actionsFromSut' <- makeTInputStream (readTQueue observedQueue) hasObservation+    inputCommandsToSut' <- makeOutputStream $ \mInCmd -> do+        ensureObservationTime+        case mInCmd of+            Just (Just inCmd) -> Streams.write (Just inCmd) $ inputCommandsToSut adap+            Just Nothing -> atomically $ waitUntil $ not <$> isEmptyTQueue observedQueue -- Just Nothing input means waiting, on an output or until a timeout+            Nothing -> Streams.write Nothing $ inputCommandsToSut adap -- Nothing means closing the adapter, forward this to the underlying adapter+    _ <- forkIO quiescenceMonitor+    _ <- forkIO actMonitor+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut',+        actionsFromSut = actionsFromSut',+        close = ensureObservationTime >> close adap+        }++-- | Transform the given Adapter by introducing a short delay before every provided input. See 'withInputDelay', with the delay time given in milliseconds.+withInputDelayMillis :: Int -> Adapter (IOAct i o) i' -> IO (Adapter (IOAct i o) i')+withInputDelayMillis timeDelayMillis = withInputDelay $ secondsToNominalDiffTime $ 0.001 * realToFrac timeDelayMillis++{-|+    Transform the given Adapter by introducing a short delay before passing on any provided input. If, during that delay, an observation is made, then+    that input is _not_ passed on.+    +    This may be used to slow down a tester which performs inputs too fast for observation responses to occur, both after sending an input and after+    making an observation.+-}+withInputDelay :: NominalDiffTime -> Adapter (IOAct i o) i' -> IO (Adapter (IOAct i o) i')+withInputDelay timeDelayDiff adap = do+    lastObservationTime <- newEmptyTMVarIO+    inputBlocked <- newTVarIO True+    discardInput <- newTVarIO False+    updateLastObservationTime <- newTVarIO False+    let updateObservationTime currentTime = do -- if the current time is past the stored input time, then update that observation time to now+            writeTVar inputBlocked True+            mLastTime <- tryReadTMVar lastObservationTime+            case mLastTime of+                Nothing -> writeTMVar lastObservationTime currentTime+                Just lastTime -> ifM_ (lastTime < currentTime) $ writeTMVar lastObservationTime currentTime+        getWaitTimeMicros currentTime = do -- the number of microseconds until the target timeout is reached+            lastTime <- readTMVar lastObservationTime -- should never be nothing, the unblocker ensures this+            let targetTime = addUTCTime timeDelayDiff lastTime+                currentTime' = max currentTime lastTime -- lastTime > currentTime can occur if the caller waited too long after retrieving the+                                                        -- currentTime, in particular when blocking on reading lastObservationTime+            return $ ceiling $ 1000000 * nominalDiffTimeToSeconds (diffUTCTime targetTime currentTime')+        waitUntilDelay = do+            currentTime <- getCurrentTime+            waitTimeMicros <- atomically $ getWaitTimeMicros currentTime+            ifM_ (waitTimeMicros > 0) $ do+                delay waitTimeMicros+                waitUntilDelay+        unblocker = do+            -- this exists only because STM-monads cannot wait for a given delay, so this is a monitor that waits for the right TVar state to do so+            atomically $ waitUntil $ readTVar inputBlocked &&^ (not <$> readTVar updateLastObservationTime)+            waitUntilDelay+            atomically $ writeTVar inputBlocked False+            unblocker+        observationTimeUpdater = do+            -- this exists only because STM-monads cannot fetch the current time, so this is a monitor that waits for the right TVar state to do so+            atomically $ waitUntil $ readTVar updateLastObservationTime+            currentTime <- getCurrentTime+            atomically $ do+                updateObservationTime currentTime+                writeTVar updateLastObservationTime False+            observationTimeUpdater+        waitUntilUnblocked = waitUntil $ not <$> readTVar inputBlocked+        readFromSut = do+            writeTVar updateLastObservationTime True -- signal the observationTimeUpdater to record the current time+            writeTVar discardInput True -- an observation was made: discard any pending inputs+            Streams.read $ actionsFromSut adap -- continue as usual+    void $ forkIO unblocker+    void $ forkIO observationTimeUpdater+    inputCommandsToSut' <- makeOutputStream $ \mInCmd -> do+        case mInCmd of+            Just inCmd -> do+                currentTime <- getCurrentTime+                atomically $ do+                    -- sending an input command is strictly not an observation, but treat it as an observation as well: reset the observation time+                    updateObservationTime currentTime+                    writeTVar inputBlocked True+                    writeTVar discardInput False+                discard <- atomically $ do+                    waitUntilUnblocked+                    readTVar discardInput+                    -- the previous atomic block set discardInput to False, send the input iff it wasn't set to True (due to an observation) in the meantime+                ifM_ (not discard) $ Streams.write (Just inCmd) $ inputCommandsToSut adap+            Nothing -> Streams.write Nothing $ inputCommandsToSut adap -- Nothing means closing the adapter, forward this to the underlying adapter+    actionsFromSut' <- makeTInputStream readFromSut (hasInput $ actionsFromSut adap)+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut',+        actionsFromSut = actionsFromSut',+        close = close adap -- FIXME this should also close the forked threads+        }+++-- | Transform the given Adapter by introducing a short delay after every provided input. See 'withSuccessiveInputDelay', with the delay time given in milliseconds.+withSuccessiveInputDelayMillis :: Int -> Adapter (IOAct i o) i' -> IO (Adapter (IOAct i o) i')+withSuccessiveInputDelayMillis timeDelayMillis = withSuccessiveInputDelay $ secondsToNominalDiffTime $ 0.001 * realToFrac timeDelayMillis++{-|+    Transform the given Adapter by introducing a short delay after every provided input. After an input is provided, then observing the adapter (or+    even calling `hasObservation`) will block until the specified time duration has passed, or until an output is observed, or until the action stream+    of the adapter closes, whichever comes first.+    +    This may be used to slow down a tester which performs successive inputs too fast for observation responses to occur.+    +    More precisely, this may be needed in case of a state with incoming transitions for inputs, and outgoing transitions for /both/ inputs and+    outputs. Without input delay, the tester may perform one input to enter the state, immediately observe that input, and immediately perform the+    second input from that state, whereas the wrapped adapter may receive the first input and respond with an output, followed by the second input.+    The wrapped adapter and the tester then observe different traces of actions.+    +    Note: this function does /not/ help to resolve states with an incoming transition for an /output/, and transitions for both inputs and output. To+    resolve that situation, use `withInputDelay` instead.+-}+withSuccessiveInputDelay :: NominalDiffTime -> Adapter (IOAct i o) i' -> IO (Adapter (IOAct i o) i')+withSuccessiveInputDelay timeDelayDiff adap = do+    -- FIXME loads of code duplication with withInputDelay, deduplicate this+    lastInputTime <- newEmptyTMVarIO+    observationBlocked <- newTVarIO False+    let updateInputTime currentTime = do -- if the current time is past the stored input time, then update that observation time to now+            mLastTime <- tryReadTMVar lastInputTime+            case mLastTime of+                Nothing -> writeTMVar lastInputTime currentTime+                Just lastTime -> ifM_ (lastTime < currentTime) $ writeTMVar lastInputTime currentTime+        getWaitTimeMicros currentTime = do -- the number of microseconds until the target timeout is reached+            lastTime <- readTMVar lastInputTime -- should never be nothing, the unblocker ensures this+            let targetTime = addUTCTime timeDelayDiff lastTime+                currentTime' = max currentTime lastTime -- lastTime > currentTime can occur if the caller waited too long after retrieving the+                                                        -- currentTime, in particular when blocking on reading lastObservationTime+            return $ ceiling $ 1000000 * nominalDiffTimeToSeconds (diffUTCTime targetTime currentTime')+        waitUntilDelay = do+            currentTime <- getCurrentTime+            waitTimeMicros <- atomically $ getWaitTimeMicros currentTime+            ifM_ (waitTimeMicros > 0) $ do+                delay waitTimeMicros+                waitUntilDelay+        unblocker = do+            -- this exists only because STM-monads cannot wait for a given delay, so this is a monitor that waits for the right TVar state to do so+            atomically $ waitUntil $ readTVar observationBlocked+            waitUntilDelay+            atomically $ writeTVar observationBlocked False+            unblocker+        waitUntilUnblocked = waitUntil $ not <$> readTVar observationBlocked+        waitUntilOutputOrClosed =+            doAfter (hasInput $ actionsFromSut adap) $ do -- retry if there is no action present (and hence specifically no output)+                mAct <- Streams.read $ actionsFromSut adap -- 'peek' an action (putting the action back later, because we need to peek more)+                case mAct of+                    Nothing -> return () -- the stream closed, waiting has finished+                    Just act -> do+                        case act of+                            Out _ -> writeTVar observationBlocked False -- we've found an output, so waiting has finished+                            In _ -> waitUntilOutputOrClosed -- recursively peek more, which will either find an output or retry on an absent action+                        Streams.unRead act $ actionsFromSut adap -- now put the 'peeked' action back on the queue+        readFromSut = do+            waitUntilUnblocked `orElse` waitUntilOutputOrClosed+            Streams.read $ actionsFromSut adap+        hasObservation = readTVar observationBlocked ||^ hasInput (actionsFromSut adap)+    void $ forkIO unblocker+    inputCommandsToSut' <- makeOutputStream $ \mInCmd -> do+        case mInCmd of+            Just inCmd -> do+                -- waiting is only necessary if the user of the adapter sends a second input without observing an action after the first input+                atomically $ waitUntil $ not <$> readTVar observationBlocked+                currentTime <- getCurrentTime+                atomically $ do+                    updateInputTime currentTime+                    writeTVar observationBlocked True+                Streams.write (Just inCmd) $ inputCommandsToSut adap+            Nothing -> Streams.write Nothing $ inputCommandsToSut adap -- Nothing means closing the adapter, forward this to the underlying adapter+    actionsFromSut' <- makeTInputStream readFromSut hasObservation+    return $ Adapter {+        inputCommandsToSut = inputCommandsToSut',+        actionsFromSut = actionsFromSut',+        close = close adap -- FIXME this should also close the forked threads+        }+++--------------------+-- socket adapter --+--------------------++-- | Settings for a socket Adapter.+data SocketSettings act i = SocketSettings {+    hostName :: HostName,+    portNumber :: PortNumber+    }++-- | Default settings for a socket Adapter.+baseSocketSettings :: SocketSettings act i+baseSocketSettings  = SocketSettings {+    hostName = "127.0.0.1",+    portNumber = 2929+    }++-- | Create an adapter by connecting to a server socket, with the default settings.+connectSocketAdapter :: IO (Adapter ByteString ByteString)+connectSocketAdapter = connectSocketAdapterWith baseSocketSettings++-- | Create an adapter by connecting to a server socket, with the given settings.+connectSocketAdapterWith :: SocketSettings act i -> IO (Adapter ByteString ByteString)+connectSocketAdapterWith settings = niceSocketsDo $ do+    socket <- connectTCP (hostName settings) (portNumber settings)+    (actionBytes, inputCommandBytes) <- socketToStreams socket+    forkedActionBytes <- fromInputStreamBuffered actionBytes+    return $ Adapter {+        inputCommandsToSut = inputCommandBytes,+        actionsFromSut = forkedActionBytes,+        close = Socket.gracefulClose socket 1000+    }++-- | Create an adapter by connecting to a server socket, with the default settings, and sending inputs and reading outputs in JSON format.+connectJSONSocketAdapter :: (ToJSON i, FromJSON o) => IO (Adapter o i)+connectJSONSocketAdapter = connectJSONSocketAdapterWith baseSocketSettings++-- | Create an adapter by connecting to a server socket, with the given settings, and sending inputs and reading outputs in JSON format.+connectJSONSocketAdapterWith :: (ToJSON i, FromJSON o) => SocketSettings act i -> IO (Adapter o i)+connectJSONSocketAdapterWith settings = do+    rawAdap <- connectSocketAdapterWith settings+    parsingAdap <- parseJSONActionsFromSut rawAdap+    encodeJSONTestChoices parsingAdap++-- | Create an adapter by connecting to a server socket, with the default settings, and sending inputs and reading outputs in JSON format, observing any input as accepted.+connectJSONSocketAdapterAcceptingInputs :: (ToJSON i, FromJSON o) => IO (Adapter (IOAct i o) i)+connectJSONSocketAdapterAcceptingInputs = connectJSONSocketAdapter >>= acceptingInputs++-- | Create an adapter by connecting to a server socket, with the given settings, and sending inputs and reading outputs in JSON format, observing any input as accepted.+connectJSONSocketAdapterAcceptingInputsWith :: (ToJSON i, FromJSON o) => SocketSettings act i -> IO (Adapter (IOAct i o) i)+connectJSONSocketAdapterAcceptingInputsWith settings = connectJSONSocketAdapterWith settings >>= acceptingInputs++-- | Transform the given I/O-Adapter (for action `IOAct` by interpreting the input and output actions as gate values with data parameters.+asSymbolicSuspAdapter :: Adapter (IOSuspAct (GateValue i) (GateValue o)) (Maybe (GateValue i)) -> IO (Adapter (IOSuspGateValue i o) (Maybe (GateValue i)))+asSymbolicSuspAdapter = mapActionsFromSut ioSuspActGateToSuspGateValue+    where+        ioSuspActGateToSuspGateValue (In (GateValue i cs)) = GateValue (In i) cs+        ioSuspActGateToSuspGateValue (Out (OutSusp (GateValue o cs))) = GateValue (Out (OutSusp o)) cs+        ioSuspActGateToSuspGateValue (Out Quiescence) = GateValue (Out Quiescence) []++-- | Create an adapter by connecting to a server socket, with the default settings, and sending inputs and reading outputs with data, in JSON format, observing any input as accepted.+connectJSONSocketAdapterSTSwithQuiescence ::  (ToJSON i, FromJSON o) => Int -> IO (Adapter (IOSuspGateValue i o) (Maybe (GateValue i)))+connectJSONSocketAdapterSTSwithQuiescence millis = connectJSONSocketAdapterAcceptingInputs >>= withQuiescenceMillis millis >>= asSymbolicSuspAdapter
+ src/Lattest/Exec/ADG/Aut.hs view
@@ -0,0 +1,215 @@+module Lattest.Exec.ADG.Aut(Aut(..),State(..),show,after,computeCompRel,enab,outSet,afterSet,+        statesToAut,addDelta,afterSequence,inSet,getAccesSequences, adgAutFromAutomaton,+        getTransitionExtendedAccesSequences,union,constrAut,printCompRel,getDistingCompPairs) where++import Data.Set as Set (Set)+import qualified Data.Set as Set+import Data.Map as Map (Map, (!))+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.List as List+import qualified Lattest.Model.Automaton as Automaton+import qualified Lattest.Model.StandardAutomata as StandardAutomata+import Lattest.Model.BoundedMonad(Det(..))+import Lattest.Model.Alphabet(IOAct(..),isInput,asSuspended,IOSuspAct,Suspended(..))+import Data.Bifunctor (bimap)++++data Aut a b = Aut {initial :: State a b, states :: Set (State a b), idStateMap :: Map a (State a b), inputs :: Set b, outputs :: Set b}++instance (Show a, Show b) => Show (Aut a b) where+    show (Aut initial' states' _ inps' outs') = "Initial: " ++ show initial' ++ "\n" +++                                        "States: " ++ show (Set.toList states') ++ "\n" +++                                        "Input alphabet:" ++ show inps' +++                                        "Output alphabet:" ++ show outs'+                                        --"IdStateMap: " ++ (show $ (Map.mapKeys Util.stateToName . Map.map (Util.stateToName . sid)) map)++data State a b = State {sid :: a, inp :: Set b, out :: Set b, trans :: Map b a}+    deriving (Ord)++instance (Show a) => (Show (State a b)) where+    show s = show $ sid s++instance (Eq a) => Eq (State a b) where+    (==) s1 s2 = sid s1 == sid s2+    (/=) s1 s2 = sid s1 /= sid s2++statesToAut :: (Ord a,Ord b) => State a b -> Set (State a b) -> Aut a b+statesToAut ini states' = let (m,inps',outs') = Set.foldr (\s (m',inps'',outs'') -> (Map.insert (sid s) s m', Set.union inps'' (inp s), Set.union outs'' (out s))) (Map.empty,Set.empty,Set.empty) states'+                            in Aut ini states' m inps' outs'++enab :: Ord b => State a b -> Set b+enab s = Set.union (inp s) (out s)++outSet :: Ord b => Set (State a b) -> Set b+outSet = Set.foldl (\chans state -> Set.union chans (out state)) Set.empty++inSet :: Ord b => Set (State a b) -> Set b+inSet = Set.foldl (\chans state -> Set.union chans (inp state)) Set.empty++after :: (Ord a, Ord b) => State a b -> b -> Aut a b -> Maybe (State a b)+after state mu aut =  case Map.lookup mu (trans state) of+                                    Nothing -> Nothing+                                    Just s -> Map.lookup s (idStateMap aut)++afterSet :: (Ord a, Ord b) => Set (State a b) -> b -> Aut a b -> Set (State a b)+afterSet stateSet mu aut = Set.foldl (\set s -> case after s mu aut of Nothing -> set; Just s' -> Set.insert s' set) Set.empty stateSet++afterSequence :: (Ord a, Ord b) => State a b -> [b] -> Aut a b -> Maybe (State a b)+afterSequence state [] _ = Just state+afterSequence state (mu:mus) aut =+    case after state mu aut of+        Nothing -> Nothing+        Just s -> afterSequence s mus aut++computeCompRel :: (Ord a, Ord b) => Aut a b -> Set (State a b,State a b)+computeCompRel aut = computeCompRelAbstract aut firstCompRel expandCompRel++firstCompRel :: (Ord a, Ord b) => Aut a b -> Set (State a b,State a b)+firstCompRel aut = Set.fromList [(q,q') | q <- Set.toList (states aut),  q' <- Set.toList (states aut)]++expandCompRel :: (Ord a, Ord b) => Aut a b -> Set (State a b,State a b) -> Set (State a b,State a b)+expandCompRel aut@(Aut _ states' _ _ _) rel =+    Set.fromList [(q,q') | q <- Set.toList states', q' <- Set.toList states',+             let mem = compMemFunc aut rel q q',+             all mem (Set.intersection (inp q) (inp q')) && any mem (Set.intersection (out q) (out q'))]+{-+pexpandCompRel :: (Ord a, Ord b, Show a) => (Aut a b) -> Set (State a b,State a b) -> Set (State a b,State a b)+pexpandCompRel aut@(Aut _ states _ _ _) rel =+    fst $ Util.pfold (\(p1,b1) (p2,b2) ->+              if b1 && b2+              then (Set.union p1 p2,True)+              else if b1+                   then (p1,True)+                   else if b2 then (p2,True) else (Set.empty,False))+          (List.map (\(q,q') -> let mem = compMemFunc aut rel q q'+                                in (Set.singleton (q,q), (all mem (Set.intersection (inp q) (inp q'))) && (any mem (Set.intersection (out q) (out q')))))+                 [(q,q') | q <- Set.toList states, q' <- Set.toList states])+-}++compMemFunc :: (Ord a, Ord b) => Aut a b -> Set (State a b,State a b) -> State a b -> State a b -> b -> Bool+compMemFunc aut rel q q' c = Set.member (Maybe.fromJust $ after q c aut, Maybe.fromJust $ after q' c aut)  rel++computeCompRelAbstract :: (Eq c) => Aut a b -> (Aut a b -> c) -> (Aut a b -> c -> c) -> c+computeCompRelAbstract aut firstAbstract expand =+    let first = firstAbstract aut+        second = expand aut first+    in computeCompRecAbstract first second (expand aut)++computeCompRecAbstract :: (Eq c) => c -> c -> (c -> c) -> c+computeCompRecAbstract first second f = if first == second then first+                                        else computeCompRecAbstract second (f second) f++getAccesSequences :: (Ord a,Ord b) => Aut a b -> [[b]]+getAccesSequences aut = Map.elems $ getAccesSequences' aut (Set.singleton $ initial aut) (Map.singleton (initial aut) [])++getAccesSequences' :: (Ord a,Ord b) => Aut a b -> Set (State a b) -> Map (State a b) [b] -> Map (State a b) [b]+getAccesSequences' aut toInv accMap =+    if Set.null toInv then accMap+    else let state = Set.elemAt 0 toInv+             (newToInv,newAccMap) = List.foldr (\(mu,dest) (inv,m') ->+                                                let destState = idStateMap aut ! dest+                                                in if Map.notMember destState m'+                                                    then (Set.insert destState inv, Map.insert destState ((m' ! state) ++ [mu]) m')+                                                    else (inv,m')) (Set.delete state toInv,accMap) (Map.toList (trans state))+         in getAccesSequences' aut newToInv newAccMap++extendAccWithTransition :: (Ord a,Ord b) => Aut a b -> [b] -> Set [b]+extendAccWithTransition aut acc =+    let state = Maybe.fromJust (afterSequence (initial aut) acc aut)+    in Set.map (\mu -> acc ++ [mu]) (enab state)++getTransitionExtendedAccesSequences :: (Ord a,Ord b) => Aut a b -> [[b]]+getTransitionExtendedAccesSequences aut = Set.toList $ Set.unions $ Set.fromList (getAccesSequences aut) : List.map (extendAccWithTransition aut) (getAccesSequences aut)++union :: (Ord a,Ord b) => Aut a b -> Aut a b -> Aut a b+union (Aut initial1 states1 idStateMap1 inputs1 outputs1) (Aut _ states2 idStateMap2 inputs2 outputs2) =+    if Set.null $ Set.intersection states1 states2+    then Aut initial1 (Set.union states1 states2) (Map.union idStateMap1 idStateMap2) (Set.union inputs1 inputs2) (Set.union outputs1 outputs2)+    else error "states identifiers of automata not disjunct"++constrAut :: (Ord a, Ord b, Show a, Show b) => (a, Set (a,b,a), Set b, Set b) -> Aut a b+constrAut (initial', transs, inps', outs') =+    let statemap = stautToStateMap transs inps' outs'+        noTransStates = [t | (_,_,t) <- Set.toList transs, Map.notMember t statemap]+        fullStateMap = List.foldr (\s m -> Map.insert s (Set.empty,Set.empty,Map.empty) m) statemap noTransStates+         in case Map.lookup initial' fullStateMap of+                Nothing -> error "Initial state does not have any transitions"+                Just (ini,outi,tmapi) ->+                    let statesandmap = getStatesAndMap fullStateMap+                     in uncurry (Aut (State initial' ini outi tmapi)) statesandmap inps' outs'+  where+    getStatesAndMap :: (Ord a, Ord b) => Map a (Set b, Set b, Map b a) -> (Set (State a b), Map a (State a b))+    getStatesAndMap =+        Map.foldlWithKey (\setandmap key val -> case val of+            (ins,outs,tmaps) ->+                let state = State key ins outs tmaps+                in bimap (Set.insert state) (Map.insert key state) setandmap) (Set.empty,Map.empty)++    stautToStateMap :: (Ord a, Ord b, Show a, Show b) => Set (a,b,a) -> Set b -> Set b -> Map a (Set b, Set b, Map b a)+    stautToStateMap transs' inps outs =+        Set.foldl (\m t -> case t of+            (f, mu, t') -> -- map: statid -> (inp,out,Map(sym,statid))+                if Set.member mu inps then Map.insertWith (mergeMaps f) f (Set.singleton mu, Set.empty,Map.singleton mu t') m+                else if Set.member mu outs then Map.insertWith (mergeMaps f) f (Set.empty,Set.singleton mu,Map.singleton mu t') m+                else error ("Channel " ++ show mu ++ " neither input nor output!") -- ++ (show (f, mu, t)))+                                          ) Map.empty transs'++    mergeMaps :: (Ord b, Show a, Show b) => a -> (Set b, Set b, Map b a) -> (Set b, Set b, Map b a) -> (Set b, Set b, Map b a)+    mergeMaps f (ni,no,nm) (oi,oo,om) =+        case Map.toList nm of+          [] -> error "stautdef empty Map: this error was written in a refactor, this function used to crash on an empty Map but I'm not sure why"+          -- [] -> (Set.union ni oi, Set.union no oo, Map.insert c s om)+          (c,s):_ -> case Map.lookup c om of+            Nothing -> (Set.union ni oi, Set.union no oo, Map.insert c s om)+            Just d -> error ("stautdef nondeterministic!\n" ++ show f ++ " -> " ++ show c ++ " -> " ++ show d ++ " AND " ++ show f ++ " -> " ++ show c ++ " -> " ++ show s)++addDelta :: (Ord a) => String -> Aut a String -> Aut a String+addDelta delta (Aut initial' states' _ inputs' outputs') =+    let newStates = Set.foldl (\set s@(State sid' inp' out' trans') ->+                                       if Set.null out'+                                       then Set.insert (State sid' inp' (Set.insert delta out') (Map.insert delta sid' trans')) set+                                       else Set.insert s set) Set.empty states'+        stateMap = (Map.fromList $ List.map (\s -> (sid s,s)) $ Set.toList newStates)+    in Aut (stateMap Map.! sid initial') newStates stateMap inputs' (Set.insert delta outputs')+++printCompRel :: (Show a, Eq a) => Set (State a b,State a b) -> String+printCompRel compRel = List.intercalate "\n" (Set.toList $ Set.map (\t -> "(s" ++ show (sid $ fst t) ++ ", s" ++ show (sid $ snd t) ++ ")") (Set.filter (uncurry (/=)) compRel))++getDistingCompPairs :: (Ord a, Ord b) => Aut a b -> Set (State a b,State a b) -> [b] -> Int+getDistingCompPairs aut comp sigma =+    List.length [(q1,q2) | (q1,q2) <- Set.toList comp,+                           case (afterSequence q1 sigma aut, afterSequence q2 sigma aut) of+                                (Just _, Nothing) -> True+                                (Nothing, Just _) -> True+                                _ -> False]++adgAutFromAutomaton :: (Ord a, Ord b) => StandardAutomata.ConcreteSuspAutIntrpr Det a b b -> b -> Maybe (Aut a b)+adgAutFromAutomaton aut delta = let+    stateIds = Automaton.reachable $ Automaton.syntacticAutomaton aut+    alphabet = Set.map asSuspended $ Automaton.alphabet $ Automaton.syntacticAutomaton aut+    (inputs',outputs') = Set.foldr (\l (i,o) -> if isInput l then (Set.insert l i,o) else (i,Set.insert l o)) (Set.empty,Set.singleton (Out Quiescence)) alphabet+    stateTrans = Set.map (\sid' -> (sid', insertTransitions sid' (insertTransitions sid' Map.empty inputs' aut delta) outputs' aut delta)) stateIds+    (inp',out') = (Set.map (getLabel delta) inputs', Set.map (getLabel delta) outputs')+    stateMap = Map.fromList $ Set.toList $ Set.map (\(sid',trans') -> (sid', State sid' (Set.intersection inp' $ Set.fromList $ Map.keys trans') (Set.intersection out' $ Set.fromList $ Map.keys trans') trans')) stateTrans+    in case Automaton.stateConf aut of+        Det q -> case Map.lookup q stateMap of+            Nothing -> Nothing+            Just s -> Just $ statesToAut s $ Set.fromList $ Map.elems stateMap+        ForbiddenDet -> error "Forbidden"+        UnderspecDet -> error "Underspecified"+    where+        insertTransition :: (Ord a, Ord b) => a -> Map b a -> IOSuspAct b b -> StandardAutomata.ConcreteSuspAutIntrpr Det a b b -> b -> Map b a+        insertTransition sid' m' ioact aut' delta' =+            case Automaton.stateConf (Automaton.inConfiguration aut' (Det sid') `Automaton.after` ioact) of+                Det q -> Map.insert (getLabel delta' ioact) q m'+                _ -> m'+        getLabel :: b -> IOSuspAct b b -> b+        getLabel delta' ioact =  case ioact of+                             (In i) -> i+                             (Out (OutSusp o)) -> o+                             (Out Quiescence) -> delta'+        insertTransitions :: (Ord a, Ord b) => a -> Map b a -> Set (IOSuspAct b b) -> StandardAutomata.ConcreteSuspAutIntrpr Det a b b -> b -> Map b a+        insertTransitions sid' trans' alf aut' delta' = Set.foldr (\l m' -> insertTransition sid' m' l aut' delta') trans' alf
+ src/Lattest/Exec/ADG/DistGraph.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE LambdaCase #-}+module Lattest.Exec.ADG.DistGraph(getPairsForState,getStartStatesLeaves,getEvidenceStats,computeAdaptiveDistGraph) where++import Data.Set as Set (Set)+import qualified Data.Set as Set+import qualified Data.Maybe as Maybe+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import qualified Control.Parallel.Strategies as Parallel++import qualified Lattest.Exec.ADG.SplitGraph as SplitGraph+import Lattest.Exec.ADG.SplitGraph as SplitGraph (SplitGraph, SplitNode,Evidence(..))+import qualified Lattest.Exec.ADG.Aut as Aut+import Lattest.Exec.ADG.Aut as Aut (Aut, State)++computeAdaptiveDistGraph :: (Ord a, Ord b) => Aut a b -> Bool -> Bool -> Bool -> Evidence b+computeAdaptiveDistGraph aut doBestSplit splitOutputFirst useBucketLCA = let+    compRel = Aut.computeCompRel aut+    (splitGraph,_nadmin) = SplitGraph.buildSplitGraph aut compRel (SplitGraph.initializeSplitGraphAdmin doBestSplit splitOutputFirst True)+    in buildDistGraph aut splitGraph (Aut.states aut) compRel useBucketLCA++buildDistGraph :: (Ord a, Ord b) => Aut a b -> SplitGraph a b -> Set (State a b) -> Set (State a b,State a b) -> Bool -> Evidence b+buildDistGraph aut graph stateSet compRel =+  buildDistGraph' aut graph stateSet Nil compRel (Map.singleton (Aut.states aut) (Set.singleton $ SplitGraph.getRootNode graph))++buildDistGraph' :: (Ord a, Ord b) => Aut a b -> SplitGraph a b -> Set (State a b) -> Evidence b -> Set (State a b,State a b) -> Map (Set (State a b)) (Set (SplitNode a b)) -> Bool -> Evidence b+buildDistGraph' aut graph stateSet dg compRel lcaMap useBucketLCA =+    if SplitGraph.isUnsplittable stateSet compRel+    then -- Trace.trace ((++) "Unsplittable: " $ show $ Set.map Aut.sid stateSet)+        dg+    else case dg of+        Nil -> let (ev,nlcaMap) = getEvFromLCA aut graph stateSet compRel lcaMap useBucketLCA+               in -- Trace.trace ((++) "P= " $ show $ Set.map Aut.sid stateSet) $ -- Set.size stateSet)+                  buildDistGraph' aut graph stateSet ev compRel nlcaMap useBucketLCA+        Prefix mu bexp -> -- Trace.trace (((++) "P= " $ show $ Set.map Aut.sid stateSet) ++ " mu= " ++ mu)+                            Prefix mu (buildDistGraph' aut graph (Aut.afterSet stateSet mu aut) bexp compRel lcaMap useBucketLCA)+        Plus bexps -> let todoList = List.map (\bexp -> buildDistGraph' aut graph stateSet bexp compRel lcaMap useBucketLCA) bexps+                          resList = todoList `Parallel.using` Parallel.parList Parallel.rpar+                      in Plus resList++getEvFromLCA :: (Ord a, Ord b) => Aut a b -> SplitGraph a b -> Set (State a b) -> Set (State a b,State a b) -> Map (Set (State a b)) (Set (SplitNode a b)) -> Bool -> (Evidence b, Map (Set (State a b)) (Set (SplitNode a b)))+getEvFromLCA aut graph stateSet compRel lcaMap useBucketLCA =+    let (lcas,nlcaMap) = case Map.lookup stateSet lcaMap of+                            Just lcaNodes -> (lcaNodes, lcaMap)+                            Nothing -> let lcaNodes = (if useBucketLCA then SplitGraph.getLCA else SplitGraph.getAllLCAsTopDown) graph stateSet+                                       in (lcaNodes, Map.insert stateSet lcaNodes lcaMap)+        splitnode = SplitGraph.getMaxInjective aut stateSet compRel id lcas+    in -- Trace.trace ((++) "lca= " $ show $ splitnode) $+            (Maybe.fromJust $ SplitGraph.evidence splitnode, nlcaMap)++getEvidenceStats :: (Ord a, Ord b) => Aut a b -> Evidence b -> (Int,Int,Int,Int,Int,Int)+getEvidenceStats aut adg =+    let evTrans = getEvTrans adg+        pruneEvTrans = getEvTrans $ prune aut (Aut.states aut) adg+    in (getNrTreeNodes evTrans, getNrEvAutNodes evTrans, getNrEvLeaves evTrans, getNrTreeNodes pruneEvTrans, getNrEvAutNodes pruneEvTrans, getNrEvLeaves pruneEvTrans)+    where+        getNrTreeNodes trans = 1 + List.length trans -- root plus alle states die een parent hebben+        getNrEvAutNodes trans = 1+ Set.size (Set.fromList [s | (s,_,_) <- trans]) -- leaf Nil + all non-leaf nodes+        getNrEvLeaves trans = List.length $ List.filter (\(_,_,ev) -> case ev of SplitGraph.Nil -> True; _ -> False) trans+++prune :: (Ord a, Ord b) => Aut a b -> Set (State a b) -> Evidence b -> Evidence b+prune _ _ Nil = Nil+prune aut set (Prefix mu ev) = let nset = Aut.afterSet set mu aut in if Set.null nset then Nil else Prefix mu (prune aut nset ev)+prune aut set (Plus evs) = let res = List.filter (\case Nil -> False; _ -> True) $ List.map (prune aut set) evs+                           in if List.null res then Nil else Plus res++getEvTrans :: Evidence b -> [(Evidence b, b, Evidence b)]+getEvTrans Nil = error "Nil encountered"+getEvTrans p@(Prefix mu Nil) = [(p,mu,Nil)]+getEvTrans p@(Prefix mu ev) = (p,mu,ev) : getEvTrans ev+getEvTrans p@(Plus evs) = List.foldl (\tr ev -> case ev of+    Prefix mu Nil -> (p,mu,Nil) : tr+    Prefix mu ev' -> (p,mu,ev'): getEvTrans ev' ++ tr+    Nil -> error "Nil encountered"+    Plus{} -> error "Plus encountered"+  ) [] evs++getStartStatesLeaves :: (Ord a, Ord b) => Aut a b -> Evidence b ->  [Set (State a b)]+getStartStatesLeaves aut ev =+    let states = Aut.states aut+    in getStartStatesLeaves' aut ev (Set.fromList [ (s,s) | s <- Set.toList states]) states++getStartStatesLeaves' :: (Ord a, Ord b) => Aut a b -> Evidence b -> Set (State a b,State a b) -> Set (State a b) ->  [Set (State a b)]+getStartStatesLeaves' _ Nil initcurmap leafStates = [Set.fromList [ i | (i,c) <- Set.toList initcurmap, Set.member c leafStates ]]+getStartStatesLeaves' aut (Prefix mu ev) initcurmap evStates =+    let nevStates = Aut.afterSet evStates mu aut+        ninitcurmap = Set.foldl (\set (i,c) -> case Aut.after c mu aut of+                                                Nothing -> set+                                                Just d -> Set.insert (i,d) set) Set.empty initcurmap+    in getStartStatesLeaves' aut ev ninitcurmap nevStates+getStartStatesLeaves' aut (Plus evs) initcurmap evStates =+    concatMap (\ev -> getStartStatesLeaves' aut ev initcurmap evStates) evs++getPairsForState :: (Ord a, Ord b) => Aut a b -> Set(State a b,State a b) -> State a b -> Set (Set (State a b))+getPairsForState aut compRel state =+    Set.foldr (\s set -> if Set.member (s,state) compRel then set else Set.insert (Set.insert s $ Set.singleton state) set) Set.empty (Set.delete state $ Aut.states aut)
+ src/Lattest/Exec/ADG/SplitGraph.hs view

file too large to diff

+ src/Lattest/Exec/StandardTestControllers.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-}++{- |+    This module contains building blocks for constructing out-of-the-box 'TestController's.+    +    'TestController's have multiple duties during testing:+    +    * selecting test inputs,+    * deciding whether to continue testing,+    * returning testing results (other than 'Pass' or 'Fail'), and+    * potentially performing side effects during testing.+    +    The building blocks in this module allow composing 'TestController's in a modular way, by combining various choices for these responsibilities.+    Every building block carries its own state. For example, to stop testing after a fixed number of steps, a state in the form of a counter is+    needed, whereas returning the observed trace as test result requires recording the observed trace as state.+-}++module Lattest.Exec.StandardTestControllers (+-- * Test Selectors+selector,+TestSelector,+randomTestSelector,+randomTestSelectorFromSeed,+randomTestSelectorFromGen,+randomDataTestSelector,+randomDataTestSelectorFromSeed,+randomDataTestSelectorFromGen,+randomDataOrWaitForOutputTestSelector,+randomDataOrWaitForOutputTestSelectorFromSeed,+randomDataOrWaitForOutputTestSelectorFromGen,+andThen,+-- * Stop Conditions+StopCondition,+stopCondition,+untilCondition,+stopAfterSteps,+-- * Test Observers+TestObserver,+observer,+andObservingWith,+andObserving,+observingOnly,+traceObserver,+stateObserver,+inconclusiveStateObserver,+-- * Test Side Effects+TestSideEffect,+withSideEffect,+testSideEffect,+printActions,+printState+)+where++import Lattest.Exec.Testing(TestController(..))+import Lattest.Model.Alphabet(TestChoice, IOAct(..), actToChoice, SymInteract(..), IOSymInteract, GateValue(..), IOGateValue, SymGuard, IOSuspGateValue)+import Lattest.Model.Automaton(AutIntrpr(..), StepSemantics, FiniteMenu, specifiedMenu, stateConf, IntrpState(..), STStdest, After)+import Lattest.Model.StandardAutomata(IOSTSIntrp)+import Lattest.Model.BoundedMonad(isConclusive, BoundedConfiguration, BooleanConfiguration)+import Lattest.Model.Symbolic.SolveSTS(solveRandomInteraction)+import Lattest.SMT(runSMT)+import Lattest.Util.Utils(takeRandom, flipCoin)++import Data.Either.Combinators(leftToMaybe, maybeToLeft)+import qualified Lattest.Model.BoundedMonad as BM+import System.Random(RandomGen, StdGen, initStdGen, mkStdGen)+import Data.Maybe (mapMaybe)++++{- |+    'Testselector's are test controllers that are only concerned with selecting inputs for testing. They do not return any testing results.+-}+type TestSelector m loc q t tdest act s i = TestController m loc q t tdest act s i ()++{- |+    Create a 'TestSelector'. Requires one function to select an input, also updating the state, and one function to update the state when observing+    an action.+-}+selector ::+    state ->+    (state -> AutIntrpr m loc q t tdest act -> m q -> IO (Maybe (i, state))) ->+    (state -> AutIntrpr m loc q t tdest act -> act -> m q -> IO (Maybe state)) ->+    TestSelector m loc q t tdest act state i+selector state sel upd = TestController {+    testControllerState = state,+    selectTest = \s aut mq -> maybeToLeft () <$> sel s aut mq,+    updateTestController = \s aut act mq -> maybeToLeft () <$> upd s aut act mq,+    handleTestClose = const $ return ()+    }++-- TODO introduce a combinator that adds the 'selector' behaviour to an arbitrary TestController. This is not needed if the selector is always +-- taken as a basis to combine with stop conditions / test observers, but it would be more flexible to allow turning a composition around.++{- |+    A 'TestSelector' that picks inputs uniformly pseudo-randomly from the outgoing transitions from the current state configuration.+-}+randomTestSelector :: (After m loc q t tdest act, FiniteMenu t act, Foldable m, TestChoice i act, Ord act, Ord q, Ord (m q))+    => IO (TestSelector m loc q t tdest act StdGen i)+randomTestSelector = randomTestSelectorFromGen <$> initStdGen++{- |+    A 'TestSelector' that picks inputs uniformly pseudo-randomly from the outgoing transitions from the current state configuration, starting with+    the given random seed.+-}+randomTestSelectorFromSeed :: (After m loc q t tdest act, FiniteMenu t act, Foldable m, TestChoice i act, Ord act, Ord q, Ord (m q))+    => Int -> TestSelector m loc q t tdest act StdGen i+randomTestSelectorFromSeed i = randomTestSelectorFromGen $ mkStdGen i++{- |+    A 'TestSelector' that picks inputs uniformly pseudo-randomly from the outgoing transitions from the current state configuration, based on the+    given random generator.+-}+randomTestSelectorFromGen :: (After m loc q t tdest act, FiniteMenu t act, Foldable m, TestChoice i act, RandomGen g, Ord act, Ord q, Ord (m q))+    => g -> TestSelector m loc q t tdest act g i+randomTestSelectorFromGen g = selector g randomSelectTest (\s _ _ _ -> return $ Just s)+    where+    randomSelectTest g' aut _ =+        let ins = mapMaybe actToChoice (specifiedMenu aut)+        in if null ins+            then error "random test selector found an empty menu"+            else return $ Just $ takeRandom g' ins++{- |+    A 'TestSelector' that picks inputs uniformly pseudo-randomly from the outgoing transitions from the current state configuration.+-}+randomDataTestSelector :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard))+    => IO (TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o) StdGen (GateValue i))+randomDataTestSelector = randomDataTestSelectorFromGen <$> initStdGen++{- |+    A 'TestSelector' that picks inputs uniformly pseudo-randomly from the outgoing transitions from the current state configuration, starting with+    the given random seed.+-}+randomDataTestSelectorFromSeed :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard))+    => Int -> TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o) StdGen (GateValue i)+randomDataTestSelectorFromSeed i = randomDataTestSelectorFromGen (mkStdGen i)++{- |+    A 'TestSelector' that picks input gates uniformly pseudo-randomly from the outgoing transitions from the current state configuration, based on the+    given random generator, with arbitrary data values as picked by the given SMT solver. Will immediately stop if it cannot find any possible data values for any input gate.+-}+randomDataTestSelectorFromGen :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard), RandomGen g)+    => g -> TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o) g (GateValue i)+randomDataTestSelectorFromGen g = selector g solveRandomIfPossible (\s _ _ _ -> return $ Just s)+    where+    solveRandomIfPossible :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOGateValue i o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard), RandomGen g)+        => g -> IOSTSIntrp m loc i o -> m (IntrpState loc) -> IO (Maybe (GateValue i, g))+    solveRandomIfPossible g'' intrpr _ = do+        (maybeGateValue, g') <- solveRandomInput g'' maybeFromIOAct intrpr+        return $ case maybeGateValue of+            Nothing -> Nothing+            Just value -> Just (value, g')+    maybeFromIOAct :: SymInteract (IOAct i1 o1) -> Maybe (SymInteract i1)+    maybeFromIOAct = error ""++{- |+    A 'TestSelector' that picks input gates uniformly pseudo-randomly from the outgoing transitions from the current state configuration, with arbitrary+    data values as picked by the given SMT solver. See 'randomDataOrWaitForOutputTestSelectorFromGen' for details.+-}+randomDataOrWaitForOutputTestSelector :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard))+    => Double -> IO (TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o) StdGen (Maybe (GateValue i)))+randomDataOrWaitForOutputTestSelector pWait = do+    r <- initStdGen+    return $ randomDataOrWaitForOutputTestSelectorFromGen r pWait++{- |+    A 'TestSelector' that picks input gates uniformly pseudo-randomly from the outgoing transitions from the current state configuration, starting with+    the given random seed., with arbitrary data values as picked by the given SMT solver. See 'randomDataOrWaitForOutputTestSelectorFromGen' for details.+-}+randomDataOrWaitForOutputTestSelectorFromSeed :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o), BooleanConfiguration m, Ord i, Ord o, Ord (m SymGuard))+    => Int -> Double -> TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o) StdGen (Maybe (GateValue i))+randomDataOrWaitForOutputTestSelectorFromSeed i = randomDataOrWaitForOutputTestSelectorFromGen (mkStdGen i)++{- |+    A 'TestSelector' that picks input gates uniformly pseudo-randomly from the outgoing transitions from the current state configuration, based on the+    given random generator, with arbitrary data values as picked by the given SMT solver. It may instead also omit picking an input gate, and wait +    for an output value instead, with the givene probability (clamped to [0,1]). Will always wait for an output if it cannot find any possible data+    values for any input gate.+-}+randomDataOrWaitForOutputTestSelectorFromGen :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o), BooleanConfiguration m, Ord i, Ord o, RandomGen g, Ord (m SymGuard))+    => g -> Double -> TestSelector m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o) g (Maybe (GateValue i))+randomDataOrWaitForOutputTestSelectorFromGen g pWait = selector g (solveRandomOrWait pWait) (\s _ _ _ -> return $ Just s)+    where+    solveRandomOrWait :: (StepSemantics m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o), BooleanConfiguration m, Ord i, Ord o, RandomGen g, Ord (m SymGuard))+        => Double -> g -> AutIntrpr m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i' o) -> m (IntrpState loc) -> IO (Maybe (Maybe (GateValue i), g))+    solveRandomOrWait pWait' g'' intrpr _ =+        let (doWait, g') = flipCoin g'' pWait'+        in if doWait+            then return $ Just (Nothing, g')+            else Just <$> solveRandomInput g' maybeFromIFInteraction intrpr+    maybeFromIFInteraction :: IOSymInteract i o -> Maybe (SymInteract i)+    maybeFromIFInteraction (SymInteract (In i) vars) = Just $ SymInteract i vars+    maybeFromIFInteraction (SymInteract _ _) = Nothing++solveRandomInput :: (BM.OrdMonad m, BooleanConfiguration m, Ord g, Ord (m SymGuard), RandomGen r)+    => r -> (SymInteract g -> Maybe (SymInteract i)) -> AutIntrpr m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g') -> IO (Maybe (GateValue i), r)+solveRandomInput g f intrpr = do+    (maybeGateValue, g') <- runSMT $ solveRandomInteraction intrpr f g+    return (maybeGateValue, g') -- append the new state to the solved value, if any+{-        maybeFromIFInteraction' (SymInteract gate vars) = case maybeFromInput gate of+            Just i -> Just $ SymInteract i vars+            Nothing -> Nothing+-}++{- |+    Creates a TestController that first selects inputs according to the first provided TestController, and when that first TestController is finished, selects inputs according to the second provided TestController++    Note: the result from the first tester is currently dropped.+-}+andThen :: (TestChoice i act) => TestController m loc q t tdest act state1 i r1 -> TestController m loc q t tdest act state2 i r2 -> TestController m loc q t tdest act (Either state1 state2) i r2+andThen tester1 tester2 =+    TestController {+        testControllerState = Left $ testControllerState tester1,+        selectTest = andThenSelect,+        updateTestController = andThenUpdate,+        handleTestClose = \case+            (Left _) -> handleTestClose tester2 (testControllerState tester2)+            (Right s) -> handleTestClose tester2 s+    }+    where+        andThenSelect testState specState mq = case testState of+            (Left s) -> do+                res <- selectTest tester1 s specState mq+                case res of+                    Left (i1,s1) -> return $ Left (i1, Left s1)+                    Right _ -> do -- TODO: propagate results from first TestController to resulting TestController+                        res2 <- selectTest tester2 (testControllerState tester2) specState mq+                        return $ case res2 of+                            Left (i2,s2) -> Left (i2, Right s2)+                            Right r2 -> Right r2+            (Right s) -> do+                res2 <- selectTest tester2 s specState mq+                return $ case res2 of+                    Left (i2,s2) -> Left (i2, Right s2)+                    Right r2 -> Right r2+        andThenUpdate testState specState ioact mq = case testState of+            Left s -> do+                res1 <- updateTestController tester1 s specState ioact mq+                return $ case res1 of+                    Left s1 ->  Left $ Left s1+                    Right _ -> Left $ Right $ testControllerState tester2+            Right s -> do+                res2 <- updateTestController tester2 s specState ioact mq+                return $ case res2 of+                    Left s2 ->  Left $ Right s2+                    Right r2 -> Right r2+++{- |+    'StopCondition's are test controllers that are only concerned with deciding whether to continue testing after observing an action. They do not+    select inputs or return any testing results.+-}+type StopCondition m loc q t tdest act s = TestController m loc q t tdest act s () ()++{- |+    Create a state-based stop condition, starting in the given initial state. The provided function should provide either 'Just' a new state to continue+    testing, or 'Nothing' to stop testing.+-}+stopCondition :: s -> (s -> AutIntrpr m loc q t tdest act -> act -> m q -> IO (Maybe s)) -> StopCondition m loc q t tdest act s+stopCondition state upd = TestController {+    testControllerState = state,+    selectTest = \s _ _  -> return $ Left ((), s), -- no state change, continue testing+    updateTestController = \s aut act q -> do+        maybeS' <- upd s aut act q+        case maybeS' of+            Just s' -> return $ Left s'+            Nothing -> return $ Right (),+    handleTestClose = const $ return ()+    }++{- |+    Apply a stop condition: run the (first) test controller until it returns a result, or until the stop condition is reached. The selected inputs and returned result come from the test controller.+-}+untilCondition :: TestController m loc q t tdest act state1 i1 r1 -> TestController m loc q t tdest act state2 i2 r2 -> TestController m loc q t tdest act (state1,state2) i1 r1+untilCondition controller condition = TestController {+    testControllerState = (testControllerState controller, testControllerState condition),+    selectTest = \s aut mq -> do+        next <- selectTest controller (fst s) aut mq+        return $ case next of+            Left (i,s') -> Left (i,(s',snd s))+            Right r -> Right r,+    updateTestController = \s aut act q -> do+        stateOrResult <- updateTestController controller (fst s) aut act q+        maybeCondState <- updateStopCondition condition (snd s) aut act q+        case stateOrResult of+            Left state -> case maybeCondState of+                Just condState -> return $ Left (state, condState)+                Nothing -> Right <$> handleTestClose controller state+            Right result -> return $ Right result,+    handleTestClose = handleTestClose controller . fst+    }+    where+    updateStopCondition :: TestController m loc q t tdest act state i r -> state -> AutIntrpr m loc q t tdest act -> act -> m q -> IO (Maybe state)+    updateStopCondition condition' state aut act q = leftToMaybe <$> updateTestController condition' state aut act q+++{- |+    Observe a fixed number of actions, and then stop testing.+    +    Note: since stop conditions only decide whether to stop testing after observing an action, the minimum number of actions to observe is 1.+-}+stopAfterSteps :: Int -> StopCondition m loc q t tdest act Int+stopAfterSteps n = stopCondition n (\n' _ _ _ -> return $ if n' <= 1 then Nothing else Just (n'-1))++{- |+    'TestObserver's are only concerned with returning a result after testing. They do not select inputs or decide whether to continue testing.+-}+type TestObserver m loc q t tdest act s r = TestController m loc q t tdest act s () r++{- |+    Create a 'TestObserver'.+-}+observer :: s -> (s -> AutIntrpr m loc q t tdest act -> act -> m q -> IO s) -> (s -> IO r) -> TestObserver m loc q t tdest act s r+observer state upd finish = TestController {+    testControllerState = state,+    selectTest = \s _ _ -> return $ Left ((), s), -- no state change, continue testing+    updateTestController = \s aut act q -> Left <$> upd s aut act q,+    handleTestClose = finish+    }++{- |+    Apply an observer: Use the (former) test controller, but also returning the result of the (latter) observer. Combine the two results using the given function.+-}+andObservingWith :: TestController m loc q t tdest act state1 i1 r1 -> (r1 -> r2 -> r) -> TestController m loc q t tdest act state2 i2 r2 -> TestController m loc q t tdest act (state1,state2) i1 r+andObservingWith controller f obs = TestController {+    testControllerState = (testControllerState controller, testControllerState obs),+    selectTest = \s aut mq -> do+        next <- selectTest controller (fst s) aut mq+        case next of+            Left (i,s') -> return $ Left (i,(s',snd s))+            Right r1 -> do+                r2 <- handleTestClose obs (snd s)+                return $ Right $ f r1 r2,+    updateTestController = \s aut act q -> do+        stateOrResult1 <- updateTestController controller (fst s) aut act q+        stateOrResult2 <- updateTestController obs (snd s) aut act q+        case stateOrResult1 of+            Left s1 -> case stateOrResult2 of+                Left s2 -> return $ Left (s1, s2)+                Right r2 -> do+                    r1 <- handleTestClose controller s1+                    return $ Right $ f r1 r2+            Right r1 -> case stateOrResult2 of+                Left s2 -> do+                    r2 <- handleTestClose obs s2+                    return $ Right $ f r1 r2+                Right r2 -> return $ Right $ f r1 r2,+    handleTestClose = \(s1,s2) -> do+        r1 <- handleTestClose controller s1+        r2 <- handleTestClose obs s2+        return $ f r1 r2+    }++{- |+    Apply an observer: use the (former) test controller, but also returning the result of the (latter) observer in a tuple.+-}+andObserving :: TestController m loc q t tdest act state1 i1 r1 -> TestController m loc q t tdest act state2 i2 r2 -> TestController m loc q t tdest act (state1,state2) i1 (r1,r2)+andObserving controller = andObservingWith controller (,)++{- |+    Apply an observer: use the (former) test controller, but only return the result of the (latter) observer.+-}+observingOnly :: TestController m loc q t tdest act state1 i1 r1 -> TestController m loc q t tdest act state2 i2 r2 -> TestController m loc q t tdest act (state1,state2) i1 r2+observingOnly controller = andObservingWith controller (\_ r2 -> r2)++{- |+    A 'TestObserver' that returns the trace of all observed actions+-}+traceObserver :: TestObserver m loc q t tdest act [act] [act]+traceObserver = observer [] (\trace _ act _ -> return $ act : trace) (pure . reverse)++-- FIXME get rid of the Maybe+{- |+    A 'TestObserver' that returns the last state configuration of the specification model. This may be a conclusive state. For example,+    during a failed test, this observer returns 'forbidden'.+-}+stateObserver :: TestObserver m loc q t tdest act (Maybe (m q)) (Maybe (m q))+stateObserver = observer Nothing (\_ aut _ _ -> return $ Just (stateConf aut)) return++{- |+    A 'TestObserver' that returns the last inconclusive state configuration of the specification model. For example, during a failing test,+    this observer returns the last state before the failure.+    +-}+inconclusiveStateObserver :: BoundedConfiguration m => TestObserver m loc q t tdest act (Maybe (m q)) (Maybe (m q))+inconclusiveStateObserver = observer Nothing makeSelection return+    where+    makeSelection _ aut _ mq =+        let mq' = stateConf aut+        in return $ Just $ if isConclusive mq' then mq else mq'++{- |+    'TestSideEffect's perform side effects during testing, but have no impact on the testing itself, nor on the result.+-}+type TestSideEffect m loc q t tdest act s = TestController m loc q t tdest act s () ()++{- |+    Apply a side effect: Use the (former) test controller, but also perform the side effect of the (latter) observer.+-}+withSideEffect :: TestController m loc q t tdest act state1 i1 r1 -> TestController m loc q t tdest act state2 i2 r2 -> TestController m loc q t tdest act (state1,state2) i1 r1+withSideEffect controller = andObservingWith controller const+++{- |+    Create a 'TestSideEffect'. The provided function returns the new state in an 'IO' monad that can also perform the side effects.+-}+testSideEffect :: s -> (s -> AutIntrpr m loc q t tdest act -> act -> m q -> IO s) -> TestSideEffect m loc q t tdest act s+testSideEffect s f = observer s f (const $ pure ())++{- |+    Print observed to stdin actions during testing.+-}+printActions :: Show act => TestSideEffect m loc q t tdest act ()+printActions = testSideEffect () (\_ _ act _ -> print act)++{- |+    Print the state configuration of the specification during testing.+-}+printState :: Show (m q) => TestSideEffect m loc q t tdest act ()+printState = testSideEffect () (\_ _ _ mq -> print mq)
+ src/Lattest/Exec/StandardTestControllers/CompleteTestSuite.hs view
@@ -0,0 +1,111 @@+module Lattest.Exec.StandardTestControllers.CompleteTestSuite (+accessSeqSelector,+adgTestSelector,+nCompleteSingleState,+runNCompleteTestSuite,+)+where+import Lattest.Adapter.Adapter(Adapter,close)+import Lattest.Adapter.StandardAdapters(withQuiescenceMillis)+import Lattest.Exec.ADG.Aut(adgAutFromAutomaton)+import Lattest.Exec.ADG.DistGraph(computeAdaptiveDistGraph)+import Lattest.Exec.ADG.SplitGraph(Evidence(..))+import Lattest.Exec.StandardTestControllers(andThen,randomTestSelectorFromSeed,untilCondition,stopAfterSteps,observingOnly,printActions,traceObserver,andObserving,stateObserver)+import Lattest.Exec.Testing(TestController(..), runTester,Verdict)+import Lattest.Model.Alphabet(IOAct(..), IOSuspAct, Suspended(..), asSuspended)+import Lattest.Model.Automaton(AutIntrpr(..),AutSyntax)+import Lattest.Model.BoundedMonad(Det(..))+import Lattest.Model.StandardAutomata(ConcreteSuspAutIntrpr, accessSequences, interpretQuiescentConcrete)++import Control.Monad (forM)+import qualified Data.Map as Map ((!))+import qualified Data.Set as Set (empty, Set)+import System.Random(StdGen)++{- | A TestController that selects inputs that lead to the given targetState. If unexpected outputs are selected by the SUT the TestSelector still tries to provide the inputs of the access sequence, but this may result in reaching another state.+ Result Bool is True when access sequence has been followed and false when the SUT deviated+-}+accessSeqSelector :: (Ord q, Eq i, Eq o) => ConcreteSuspAutIntrpr Det q i o -> q -> TestController Det q q (IOAct i o) () (IOSuspAct i o) [IOAct i o] (Maybe i) Bool+accessSeqSelector aut targetState =+    let initState = case stateConf aut of+            Det q -> q+            _ -> error "Access sequence: model must be in a specified initial state"+        accSeqs = accessSequences aut initState+    in TestController {+        testControllerState = (Map.!) accSeqs targetState,+        selectTest = accSeqSelectTest,+        updateTestController = accSeqUpdateTest,+        handleTestClose = \testState' -> return $ case testState' of [] ->  True; _ -> False+    }+    where+    accSeqSelectTest [] _ _ = return $ Right True+    accSeqSelectTest (l:ls) _ _ = return $ case l of+        In i -> Left (Just i, l:ls)+        _ -> Left (Nothing, l:ls)+    accSeqUpdateTest [] _ _ _ = return $ Right True+    accSeqUpdateTest (l:ls) _ label _ = return $ if asSuspended l == label then Left ls else Right False++{- | A TestController that selects inputs according to the adaptive distinguishing sequence of the given automaton+-}+adgTestSelector :: (Ord q, Ord l) => ConcreteSuspAutIntrpr Det q l l -> l ->  TestController Det q q (IOAct l l) () (IOSuspAct l l) (Evidence l) (Maybe l) (Set.Set q)+adgTestSelector aut delta =+    let adgaut = case adgAutFromAutomaton aut delta of+                    Just a -> a+                    Nothing ->  error "could not transform Lattest auomaton into ADG automaton"+        adg = computeAdaptiveDistGraph adgaut False False True+    in TestController {+        testControllerState = adg,+        selectTest = adgSelectTest,+        updateTestController = adgUpdateTest,+        handleTestClose = \_ -> return Set.empty+    }+    where+    adgSelectTest testState _ _ =+        return $ case testState of+            Nil -> Right Set.empty+            Prefix l _ -> Left (Just l, testState)+            Plus _ -> Left (Nothing,testState)++    adgUpdateTest testState _ ioact _ =+       return $ case testState of+            Nil -> Right Set.empty+            Prefix l next -> if ioact == In l then Left next else error "Error: expected to have selected an input but seeing some ioact"+            Plus ls ->+                let nextList = concatMap getNextState ls+                in case nextList of+                    [next] -> Left next+                    _ -> error "ADG error: expected to have observed one output or quiescence"+                where+                getNextState ev = case ev of+                    Nil -> []+                    Prefix l next -> if l == delta+                                        then [next | ioact == Out Quiescence]+                                     else [next | ioact == Out (OutSusp l)]+                    Plus ls' -> concatMap getNextState ls'++{- | A TestController that yields tests that tries to take an access sequence to the targetState and then executes the adaptive distinguishing sequence+-}+nCompleteSingleState :: (Ord q, Ord l) => ConcreteSuspAutIntrpr Det q l l -> Int -> Int -> l -> q+                                                    -> TestController Det q q (IOAct l l) () (IOSuspAct l l) (((), [IOSuspAct l l]), Maybe (Det q)) i20 ([IOSuspAct l l], Maybe (Det q))+                                                    -> IO (TestController Det q q (IOAct l l) () (IOSuspAct l l) (Either (Either [IOAct l l] StdGen, Int) (Evidence l), (((), [IOSuspAct l l]), Maybe (Det q))) (Maybe l) ([IOSuspAct l l], Maybe (Det q)))+nCompleteSingleState model seed nrSteps delta targetState observer = do+    return $ accessSeqSelector model targetState+        `andThen` randomTestSelectorFromSeed seed `untilCondition` stopAfterSteps nrSteps+            `andThen` adgTestSelector model delta `observingOnly` observer++{- | Runs tests from nCompleteSingleState for each given targetState and seed+-}+runNCompleteTestSuite :: (Ord q, Ord l, Show q, Show l) => IO (Adapter (IOAct l l) l) -> AutSyntax Det q (IOAct l l) () -> Int -> l -> [(q, Int)] -> IO [(q, Verdict, ([IOSuspAct l l], Maybe (Det q)))]+runNCompleteTestSuite adapter spec nrSteps delta targetStatesAndSeeds =+        forM targetStatesAndSeeds $ \(targetState,seed) -> do+            putStrLn "connecting..."+            adap <- adapter+            imp <- withQuiescenceMillis 200 adap+            let model = interpretQuiescentConcrete spec+            putStrLn "starting test..."+            putStrLn $ "accessing state: " ++ show targetState+            selector <- testSelector model seed targetState+            (verdict,(observed, maybeMq)) <- runTester model selector imp+            close adap+            return (targetState, verdict, (observed, maybeMq))+    where testSelector model seed targetState = nCompleteSingleState model seed nrSteps delta targetState $ printActions `observingOnly` traceObserver `andObserving` stateObserver
+ src/Lattest/Exec/Testing.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{- |+    This module contains the main functions and data structures to run experiments against (external) systems, specifically testing+    experiments.++    For an experiment, we assume that we have an 'Adapter', which serves as an interface to send inputs to a system under test,+    and observe actions shown by that system. The experiment is controlled by an 'ActionController'. Specifically for a testing+    experiment, we can create an 'ActionController' from a specification model that dictates which observations are allowed and+    forbidden, and a 'TestController' that steers the testing.++    To get started with testing experiments quickly, use the 'runTester' function, and to get the required ingredients, see the following modules:++    * "Lattest.Adapter.StandardAdapters" to create adapters,+    * "Lattest.Exec.StandardTestControllers" to create test controllers, and+    * "Lattest.Model.StandardAutomata" to create specification models.+-}++module Lattest.Exec.Testing (+-- * Generic Experiments+-- | Can be used to let an action controller communicate with a system under test, resulting in some arbitrary result.+ActionController(..),+runExperiment,+-- * Testing Experiments+{- |+    Specific form of experiments, in which an automaton specification model describes the intended behaviour that the system under+    test should adhere to, and the test controller sends inputs to observe whether the system under test actually conforms to that+    specification model.+    +    This is also known as /Model based testing/, see e.g.+    +    * [/Jan Tretmans/, Model based testing with labelled transition systems (Formal Methods and Testing), 2008](https://repository.ubn.ru.nl/bitstream/handle/2066/72680/72680.pdf)+-}+TestController(..),+makeTester,+RunTester(..),+runLTSTester,+runSMTTester,+Verdict(..),+InconclusiveReason(..)+)+where++import Lattest.Model.Alphabet(TestChoice)+import Lattest.Model.Automaton(StepSemantics, StepSemantics, AutIntrpr, After, IOAfter, ioAfter, stateConf, AutomatonException, STStdest)+import Lattest.Model.BoundedMonad(BoundedConfiguration, isConclusive, isForbidden)+import Lattest.Adapter.Adapter(Adapter(..), send, tryObserve)+++import Control.Exception(catch,evaluate)++--import Control.DeepSeq(force)+import Lattest.Streams.Synchronized (Streamed(..))+import Data.Kind (Constraint, Type)++-- | The controller of an experiment.+data ActionController act i r state = ActionController {+    -- | Any state that the controller needs for its decision making duties.+    controllerState :: state,+     -- | Select an input and compute the new state, /or/ decide to stop the experiment and return a result.+    select :: state -> IO (Either (i, state) r),+    -- | Provided an observed action, compute the new state /or/ stop the experiment and return a result.+    update :: state -> act -> IO (Either state r),+    -- | Handle the end of the action stream, i.e. the other end closing, ending the experiment.+    handleClose :: state -> IO r+    }++-- | The verdict resulting from a testing experiment: did the system under test pass the test?+data Verdict = Pass | Fail | Inconclusive InconclusiveReason deriving (Ord, Eq, Show)++-- | In case of an inconclusive verdict, details on why the test is inconclusive+newtype InconclusiveReason = AutomatonException AutomatonException deriving (Ord, Eq, Show)++{- |+    The controller of a testing experiment. The tester may return a result at the end of a testing experiment. Note that it does+    /not/ need to return a verdict 'Pass' or 'Fail', this verdict is automatically inferred based on the specification model.+    Results can be used to record additional information that the tester is interested in, depending on the controller implementation.+    For example, the actions observed during a testing experiment, or whether certain coverage criteria were achieved during the experiment.+-}+data TestController m loc q t tdest act state i r = TestController {+    -- | Any state that the controller needs for its decision making duties.+    testControllerState :: state,+    {- |+        Select a test based on test controller state, the specification (in its current state), and previous specification configuration.+        Either select a new controller state and a input, /or/ stop testing and return a result from the controller.+    -}+    selectTest :: (TestChoice i act) => state -> AutIntrpr m loc q t tdest act -> m q -> IO (Either (i, state) r),+    {- |+        Select a test based on test controller state, the specification (in its current state), an observed action, and previous specification+        configuration. Either select a new controller state, /or/ stop testing and return a result from the controller.+    -}+    updateTestController :: state -> AutIntrpr m loc q t tdest act -> act -> m q -> IO (Either state r),+    -- | Handle the end of the action stream, i.e. the other end closing, ending the experiment.+    handleTestClose :: state -> IO r+    }++{- |+    From a test controller and a specification model, create an action controller. The test controller is used to decide which inputs+    are supplied to the system under test, and whether to continue or stop testing. The automaton specification model is used to infer whether+    observed actions are allowed or not, and to return a verdict in case of forbidden or underspecified observations.+-}+makeTester :: (IOAfter m loc q t tdest act, StepSemantics m loc q t tdest act, TestChoice i act) =>+    AutIntrpr m loc q t tdest act -> TestController m loc q t tdest act state i r -> ActionController act i (Verdict, r) (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r)+makeTester initSpec initTestController = ActionController {+    controllerState = (initSpec, initTestController),+    select = makeSelect,+    update = makeUpdate,+    handleClose = makeHandleClose+    }+    where+        makeSelect :: (TestChoice i act, BoundedConfiguration m)+            => (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r)+            -> IO (Either (i, (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r)) (Verdict, r))+        makeSelect (spec, testController) = do+            next <- selectTest testController (testControllerState testController) spec (stateConf spec)+            case next of+                Right r -> return $ Right (pToVerd $ stateConf spec, r)+                Left (i, state') -> return $ Left (i, (spec, testController { testControllerState = state' }))+--            return $ case next of+--                Right r -> Right (pToVerd $ stateConf spec, r)+--                Left (i, state') -> Left (i, (spec, testController { testControllerState = state' }))+        makeUpdate :: (IOAfter m loc q t tdest act, StepSemantics m loc q t tdest act)+                   => (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r)+                   -> act+                   -> IO (Either (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r) (Verdict, r))+        makeUpdate (spec, testController) act = do+            spec' <- ioAfter spec act+            confOrAutomatonException <- catchAutomatonException $ stateConf spec'+            case confOrAutomatonException of+                Left conf' -> do+                    let verdict = pToVerd conf'+                    next <- updateTestController testController (testControllerState testController) spec' act (stateConf spec)+                    case next of+                        Right r -> return $ Right (verdict, r)+                        Left state' -> if isConclusive conf' || verdict == Fail+                            then do+                                r <- handleTestClose testController state'+                                return $ Right (verdict, r)+                            else return $ Left (spec', testController { testControllerState = state' })+                Right e -> do+                    r <- handleTestClose testController (testControllerState testController)+                    return $ Right (Inconclusive $ AutomatonException e, r)+        makeHandleClose :: (BoundedConfiguration m) => (AutIntrpr m loc q t tdest act, TestController m loc q t tdest act state i r) -> IO (Verdict, r)+        makeHandleClose (spec, testController) = do+            r <- handleTestClose testController (testControllerState testController)+            return (pToVerd $ stateConf spec, r)+        pToVerd :: (BoundedConfiguration m) => m x -> Verdict+        pToVerd p | isForbidden p = Fail+                  | otherwise     = Pass++catchAutomatonException :: a -> IO (Either a AutomatonException)+catchAutomatonException a = (Left <$> evaluate a) `catch` (return . Right)++{- |+    Run an experiment by interacting with the given adapter, controlled by the given action controller. The experiment+    stops when the action controller decides to. Returns the result returned by the action controller.+-}+runExperiment :: ActionController act i r state -> Adapter act i -> IO r+runExperiment controller adapter = do+    streamedAction <- tryObserve adapter+    stateOrResult <- case streamedAction of+        Available action -> handleUpdate action+        Unavailable -> handleSelect+        StreamClosed -> handleClosed+    case stateOrResult of+        Left state -> runExperiment (controller { controllerState = state }) adapter+        Right result -> return result+    where+    handleUpdate = update controller (controllerState controller)+    handleSelect = do+        selection <- select controller (controllerState controller)+        case selection of+            Left (inputCmd, state) -> do+                 -- TODO if an action is ready *after computing the input command* (because race condition between the adapter and controller), maybe don't send the input command.+                send inputCmd adapter+                return $ Left state+            Right result -> return $ Right result+    handleClosed = Right <$> handleClose controller (controllerState controller)+++{- |+    This typeclass provides 'runTester', a way to conveniently run testing experiments.+    It has instances for STSs and LTSs.+-}+class RunTester tdest where+  -- | A constraint synonym for the constraints of 'runTester'.+  --   This allows each instance to have different constraints.+  type RunnableTester (m :: Type -> Type) loc q t tdest act i :: Constraint++  {- |+      Running a tester requires:++      * a specification model in the form of an automaton, as defined in "Lattest.Model.Automaton"+      * a 'TestController', defined in this module itself, and+      * an adapter, as defined in "Lattest.Adapter.Adapter".++      Running a testing experiment is done by interacting with the given adapter, controlled by the given test controller. The experiment+      stops when the action controller decides to, or when an observation is made that is forbidden or underspecified according+      to the specification model. Returns the test verdict according to the specification model and the additional+      result returned by the test controller.+  -}+  runTester+    :: RunnableTester m loc q t tdest act i+    => AutIntrpr m loc q t tdest act+    -> TestController m loc q t tdest act state i r+    -> Adapter act i+    -> IO (Verdict, r)++instance RunTester () where+  type RunnableTester m loc q t () act i = (After m loc q t () act, TestChoice i act, Ord q, Ord (m q))+  runTester = runLTSTester++instance RunTester STStdest where+  type RunnableTester m loc q t STStdest act i = (IOAfter m loc q t STStdest act, StepSemantics m loc q t STStdest act, TestChoice i act)+  runTester = runSMTTester++runLTSTester :: (After m loc q t () act, TestChoice i act, Ord q, Ord (m q)) =>+    AutIntrpr m loc q t () act -> TestController m loc q t () act state i r -> Adapter act i -> IO (Verdict, r)+runLTSTester spec testSelection = runExperiment (makeTester spec testSelection)++runSMTTester :: (IOAfter m loc q t STStdest act, StepSemantics m loc q t STStdest act, TestChoice i act) =>+    AutIntrpr m loc q t STStdest act -> TestController m loc q t STStdest act state i r -> Adapter act i -> IO (Verdict, r)+runSMTTester spec testSelection = runExperiment (makeTester spec testSelection)+
+ src/Lattest/Model/Alphabet.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++{-|+    This module contains the definitions and semantics of different forms of observable actions, and inputs used in testing experiments.+-}++module Lattest.Model.Alphabet (+-- * Translating between Actions and Inputs+TestChoice,+choiceToActs,+actToChoice,+-- * Action types+-- ** Inputs and Outputs+IOAct(..),+isInput,+isOutput,+fromInput,+maybeFromInput,+fromOutput,+maybeFromOutput,+-- ** Observable Quiescence+{- |+    Observable actions that may be either inputs provided to a system, or outputs from that system, where the 'output' may also be an artificial+    output that represents an observed timeout, /quiescence/. For the theoretical background on observing quiescence, see+    +    * [/Jan Tretmans/, Model based testing with labelled transition systems (Formal Methods and Testing), 2008](https://repository.ubn.ru.nl/bitstream/handle/2066/72680/72680.pdf)+-}+Suspended(..),+δ,+IOSuspAct,+asSuspended,+fromSuspended,+-- TODO decide on refusal or failure and be consistent+-- ** Input Failures+{- |+    'Input failures' model the possibility to accepted or refuse an input by the system under test.+    Failure of an input represents the system being unable to process the given input. For a theoretical background on input failures, see ++    * [/Ramon Janssen/, Refinement and partiality for model-based testing (Doctoral dissertation), 2022, Chapter 3 and 4](https://repository.ubn.ru.nl/bitstream/handle/2066/285020/285020.pdf)+-}+IFAct,+InputAttempt(..),+asInputAttempt,+fromInputAttempt,+-- ** Combined Input Failures and Quiescences+SuspendedIF,+asSuspendedInputAttempt,+fromSuspendedInputAttempt,+-- * STS+SymInteract(..),+IOSymInteract,+SymGuard,+GateValue(..),+IOGateValue,+gateValueAsIOAct,+ioActAsGateValue,+maybeFromInputInteraction,+maybeFromOutputInteraction,+isInputGate,+isOutputGate,+isInputInteract,+isOutputInteract,+interactionGate,+valueGate,+IOSuspGateValue,+IFGateValue,+SuspendedIFGateValue,+toIOGateValue+)+where++import Lattest.Model.Symbolic.Expr (Variable(..), Expr(..), Constant(..))+import Data.Aeson(FromJSON, ToJSON)+import GHC.Generics (Generic)++{- |+    If an input type is an 'TestChoice' to a type of observable actions, this means that+    +    * given such an input, it is possible to derive the corresponding observable action, or sequence of actions, and+    * an observable action may (but also may not) correspond to an input.+-}+class TestChoice i act where+    {- |+        If an observable action corresponds to an input, then derive that input.+    -}+    actToChoice :: act -> Maybe i -- the input command that corresponds to given action (ideally, e.g. in case of a waiting time, the observed waiting time may be different than the intended waiting time)+    {- |+        Derive the sequence of observable actions that correspond to an input.+    -}+    choiceToActs :: i -> [act] -- which action(s) an input command corresponds to++{- |+    Observable actions that may be either inputs provided to a system, or outputs from that system.+-}+data IOAct i o = In i | Out o deriving (Eq, Ord)++instance (Show i, Show o) => Show (IOAct i o) where+    show (In i) = "?" ++ show i+    show (Out o) = "!" ++ show o++{- |+    Relates input commands to observable inputs. Note that this instance is not very practical for testing: during testing, a test controller+    is usually asked for inputs, and with this instance, it is not possible to skip selecting an input.+-}+instance TestChoice i (IOAct i o) where+    choiceToActs i = [In i]+    actToChoice (In i) = Just i+    actToChoice (Out _) = Nothing++{- |+    Is the given action an input?+-}+isInput :: IOAct i o -> Bool+isInput (In _) = True+isInput _ = False++{- |+    Is the given action an output?+-}+isOutput :: IOAct i o -> Bool+isOutput (Out _) = True+isOutput _ = False++{- |+    Partially defined function that unpacks an input.+-}+fromInput :: IOAct i o -> i+fromInput (In i) = i+fromInput (Out _) = error "fromInput called on Out action"++{- |+    Unpacks an input.+-}+maybeFromInput :: IOAct i o -> Maybe i+maybeFromInput (In i) = Just i+maybeFromInput _ = Nothing++{- |+    Partially defined function that unpacks an outputs.+-}+fromOutput :: IOAct i o -> o+fromOutput (Out o) = o+fromOutput (In _) = error "fromOutput called in In action"++{- |+    Unpacks an output.+-}+maybeFromOutput :: IOAct i o -> Maybe o+maybeFromOutput (Out o) = Just o+maybeFromOutput _ = Nothing+++{- |+    Add observation of quiescence to a type of observable actions.+-}+data Suspended o = Quiescence | OutSusp o deriving (Eq, Ord)++instance Show o => Show (Suspended o) where+    show Quiescence = "δ"+    show (OutSusp o) = show o++{- |+    Add observation of quiescence to the observed inputs and outputs.+-}+type IOSuspAct i o = IOAct i (Suspended o)++δ :: IOAct i (Suspended o)+δ = Out Quiescence++{- |+    Relates input commands to observable inputs. A 'Nothing' input command, corresponds to observation of an output, which may lead to quiescence.+-}+instance TestChoice (Maybe i) (IOSuspAct i o) where+    -- a (Maybe i) only makes sense in case of quiescence, since testing would otherwise quickly deadlock+    choiceToActs (Just i) = asSuspended <$> choiceToActs i+    choiceToActs Nothing = []+    actToChoice (Out Quiescence) = Just Nothing+    actToChoice (Out (OutSusp _)) = Nothing+    actToChoice (In i) = Just $ Just i++{- |+    Convert an input or output to a type containing quiescence.+-}+asSuspended :: IOAct i o -> IOSuspAct i o+asSuspended (In i) = In i+asSuspended (Out o) = Out (OutSusp o)++{- |+    Partially defined function that unpacks an input or output from a type with quiescence.+-}+fromSuspended :: IOSuspAct i o -> IOAct i o+fromSuspended (In i) = In i+fromSuspended (Out (OutSusp o)) = Out o+fromSuspended (Out Quiescence) = error "fromSuspended called on Quiescence"++-- (i, True) represents a succesful i, (i, False) represents a failed attempt at i+newtype InputAttempt i = InputAttempt (i, Bool) deriving (Eq, Ord)++instance Show i => Show (InputAttempt i) where+    show (InputAttempt (i, True)) = show i+    show (InputAttempt (i, False)) = showFailure (show i)+        where+        showFailure [] = []+        showFailure (c:rest) = c:'\x0305':showFailure rest -- U+0305, combine-symbol for overline++{- |+    Observable actions that may be either inputs provided to a system, or outputs from that system, where the 'inputs' may be refused.+-}+type IFAct i o = IOAct (InputAttempt i) o++{- |+    Relates input commands to observable inputs. An input command corresponds to an accepted input action, and both a refused and accepted input+    command correspond to the same input action.+-}+instance TestChoice i (IFAct i o) where+    choiceToActs i = inToInputAttempt <$> choiceToActs i+        where+        inToInputAttempt(In i') = In (InputAttempt(i', True))+        inToInputAttempt(Out o) = Out o+    actToChoice = actToChoice . attemptToIn+        where+        attemptToIn (In (InputAttempt(i', _))) = In i'+        attemptToIn (Out o) = Out o++{- |+    Convert an input or output to a type containing input failures.+-}+asInputAttempt :: IOAct i o -> IFAct i o+asInputAttempt(In i) = In (InputAttempt(i, True))+asInputAttempt(Out o) = Out o++{- |+    Partially defined function that unpacks an input or output from a type with input failures.+-}+fromInputAttempt :: IFAct i o -> IOAct i o+fromInputAttempt(In (InputAttempt(i, True))) = In i+fromInputAttempt(Out o) = Out o+fromInputAttempt _ = error "Failed fromInputAttempt"++-- ideally, this could just be defined by stacking IFAct and IOSuspAct to avoid all the boilerplate below, but that is a bit of a hassle+{- |+    Input failure with observed quiescence. See 'IOSuspAct' and 'IFAct' for details.+-}+type SuspendedIF i o = IOAct (InputAttempt i) (Suspended o)++instance TestChoice (Maybe i) (SuspendedIF i o) where+    choiceToActs Nothing = []+    choiceToActs (Just i) = inToInputAttempt <$> choiceToActs i+        where+        inToInputAttempt(In i') = In (InputAttempt(i', True))+        inToInputAttempt(Out o) = Out o+    actToChoice other = actToChoice $ attemptToIn other+        where+        attemptToIn (In (InputAttempt(i, _))) = In i+        attemptToIn (Out o) = Out o++{- |+    Convert an input or output to a type containing input failures and quiescence.+-}+asSuspendedInputAttempt :: IOAct i o -> SuspendedIF i o+asSuspendedInputAttempt(In i) = In (InputAttempt(i, True))+asSuspendedInputAttempt(Out o) = Out (OutSusp o)++{- |+    Partially defined function that unpacks an input or output from a type with input failures and quiescence.+-}+fromSuspendedInputAttempt :: SuspendedIF i o -> IOAct i o+fromSuspendedInputAttempt(In (InputAttempt(i, True))) = In i+fromSuspendedInputAttempt(Out (OutSusp o)) = Out o+fromSuspendedInputAttempt _ = error "failed fromSuspendedInputAttempt"+++-- STS data types+data SymInteract g = SymInteract g [Variable] deriving (Eq, Ord, Functor)+type IOSymInteract i o = SymInteract (IOAct i o)++interactionGate :: SymInteract g -> g+interactionGate (SymInteract g' _) = g'++instance (Show g) => Show (SymInteract g) where+    show (SymInteract g' vars) = show g' ++ " " ++ show vars++type SymGuard = Expr Bool++data GateValue g = GateValue {gate :: g, values :: [Constant]} deriving (Eq, Ord, Functor, Generic)++instance FromJSON a => FromJSON (GateValue a)+instance ToJSON a => ToJSON (GateValue a)++type IOGateValue i o = GateValue (IOAct i o)++instance (Show g) => Show (GateValue g) where+    show (GateValue g' vals) = show g' ++ if null vals then "" else show vals++valueGate :: GateValue g -> g+valueGate (GateValue g' _) = g'++gateValueAsIOAct :: IOGateValue i o -> IOAct (GateValue i) (GateValue o)+gateValueAsIOAct (GateValue (In i) vals) = In (GateValue i vals)+gateValueAsIOAct (GateValue (Out o) vals) = Out (GateValue o vals)++ioActAsGateValue :: IOAct (GateValue i) (GateValue o) -> IOGateValue i o+ioActAsGateValue (In (GateValue i vals)) = GateValue (In i) vals+ioActAsGateValue (Out (GateValue o vals)) = GateValue (Out o) vals++isOutputGate :: IOGateValue i o -> Bool+isOutputGate (GateValue (Out _) _) = True+isOutputGate _ = False++isInputGate :: IOGateValue i o -> Bool+isInputGate (GateValue (In _) _) = False+isInputGate _ = True++isOutputInteract :: IOSymInteract i o -> Bool+isOutputInteract (SymInteract (Out _) _) = True+isOutputInteract _ = False++isInputInteract :: IOSymInteract i o -> Bool+isInputInteract (SymInteract (In _) _) = False+isInputInteract _ = True++maybeFromInputInteraction :: IOSymInteract i o -> Maybe (SymInteract i)+maybeFromInputInteraction (SymInteract g' vars) = case maybeFromInput g' of+    Just i -> Just $ SymInteract i vars+    Nothing -> Nothing++maybeFromOutputInteraction :: IOSymInteract i o -> Maybe (SymInteract o)+maybeFromOutputInteraction (SymInteract g' vars) = case maybeFromOutput g' of+    Just o -> Just $ SymInteract o vars+    Nothing -> Nothing++type IOSuspGateValue i o = IOGateValue i (Suspended o)+type IFGateValue i o = IOGateValue (InputAttempt i) o+type SuspendedIFGateValue i o = IOGateValue (InputAttempt i) (Suspended o)++toIOGateValue :: SuspendedIF (GateValue i) (GateValue o) -> SuspendedIFGateValue i o+toIOGateValue (In (InputAttempt (GateValue i constantsi, bool))) = GateValue (In (InputAttempt (i,bool))) constantsi+toIOGateValue (Out Quiescence) = GateValue (Out Quiescence) []+toIOGateValue (Out (OutSusp (GateValue o constantso))) = GateValue (Out (OutSusp o)) constantso++instance TestChoice (GateValue i) (IOGateValue i o) where+    choiceToActs (GateValue i consts) = [GateValue (In i) consts]+    actToChoice (GateValue (In i) consts) = Just $ GateValue i consts+    actToChoice (GateValue (Out _) _) = Nothing++instance TestChoice (Maybe (GateValue i)) (IOSuspGateValue i o) where+    choiceToActs (Just i) = fmap asSuspended <$> choiceToActs i+    choiceToActs Nothing = []+    actToChoice (GateValue (Out Quiescence) _) = Just Nothing+    actToChoice (GateValue (Out (OutSusp _)) _) = Nothing+    actToChoice (GateValue (In i) vals) = Just $ Just $ GateValue i vals++instance TestChoice (GateValue i) (IFGateValue i o) where+    choiceToActs i = fmap inToInputAttempt <$> choiceToActs i+        where+        inToInputAttempt(In i') = In (InputAttempt(i', True))+        inToInputAttempt(Out o) = Out o+    actToChoice = actToChoice . fmap attemptToIn+        where+        attemptToIn (In (InputAttempt(i', _))) = In i'+        attemptToIn (Out o) = Out o++instance TestChoice (Maybe (GateValue i)) (SuspendedIFGateValue i o) where+    choiceToActs (Just i) = fmap inToInputAttempt <$> choiceToActs i+        where+        inToInputAttempt(In i') = In (InputAttempt(i', True))+        inToInputAttempt(Out o) = Out o+    choiceToActs Nothing = []+    actToChoice = actToChoice . fmap attemptToIn+        where+        attemptToIn (In (InputAttempt(i, _))) = In i+        attemptToIn (Out o) = Out o+
+ src/Lattest/Model/Automaton.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+    This module contains the definitions and interpretations of automata models.+-}++module Lattest.Model.Automaton (+-- * Syntactical Automaton Model+-- ** Definition+AutSyntax,+initConf,+alphabet,+trans,+transRel,+-- ** Constructing Syntactical Automata+automaton,+automaton',+-- * Semantical Automaton Model+-- ** Definition+AutIntrpr,+stateConf,+syntacticAutomaton,+-- ** Constructing Syntactical Automata+interpret,+inConfiguration,+-- ** Type Classes for Semantics+Completable,+implicitDestination,+TransitionSemantics,+StateSemantics,+StepSemantics,+after,+afters,+After,+IOAfter,+ioAfter,+-- ** Exceptions+AutomatonException(..),+-- ** Finite Transition Labels+FiniteMenu,+specifiedMenu,+-- ** STS State data types+IntrpState(..),+Valuation,+STStdest(STSLoc),+stsTLoc,+-- * Auxiliary Automaton Functions+reachable,+reachableFrom,+prettyPrint,+prettyPrintFrom,+prettyPrintIntrp+)+where++import Prelude hiding (lookup)++import Lattest.Model.BoundedMonad(BoundedMonad, BoundedConfiguration, BooleanConfiguration, isForbidden, forbidden, underspecified, isSpecified)+import qualified Lattest.Model.BoundedMonad as BM+import Lattest.Model.Alphabet(IOAct(In,Out),isOutput,IOSuspAct,Suspended(Quiescence),IFAct,InputAttempt(..),fromSuspended,asSuspended,fromInputAttempt,asInputAttempt,SuspendedIF,asSuspendedInputAttempt,fromSuspendedInputAttempt,+    SymInteract(..),IOSymInteract,GateValue(..), IOGateValue, IOSuspGateValue, IFGateValue, SuspendedIFGateValue, SymGuard, isOutputInteract, interactionGate)+import Lattest.Model.Symbolic.SolveSymPrim(combineGuards, substituteInGuard, evaluateGuard, solveAnySequential)+import Lattest.SMT(runSMT)+import Lattest.Util.Utils((&&&), takeArbitrary)++import Control.Exception(throw,Exception)++import Control.Arrow(second)++import qualified Data.Foldable as Foldable+import Data.Functor.Identity(Identity(Identity), runIdentity)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Set (Set)+import qualified Data.Set as Set++import GHC.Stack(CallStack,callStack)+import Lattest.Model.Symbolic.Expr(Valuation, VarModel, Variable(..),Type(..),Expr(..), eval, constType, varType, substConst, assignedExpr, Constant(..), toBool, fromConstantsMap, toConstantsMap, assignValues, insertIntoValuation, toConst, ConstType, Assignable)++------------+-- syntax --+------------++{- |+    Syntactical automaton model, with locations and transitions. This is analogous to an automaton drawn on paper+    with points and arrows. Transitions are mapped to /state configurations/, see "Lattest.Model.BoundedMonad".+    Furthermore, transitions contain transition labels, both on the 'outside' and in the 'inside' of the state configuration.+    +    These labels are abstract and may be interpreted in various ways, e.g. a simple automaton model may directly have+    observable actions as labels, whereas a more complex automaton model may have symbolic data variables with guards,+    assignments, clocks for timing, etc.+-}+data AutSyntax m loc t tdest = Automaton {+    initConf :: m loc,+    alphabet :: Set t,+    transRel :: loc -> Map t (m (tdest, loc))+    }++-- | Construct an automaton from an initial state configuration and a transition mapping+automaton :: (BoundedConfiguration m, Completable t, Ord t, Foldable fld) => m loc -> fld t -> (loc -> Map t (m (tdest, loc))) -> AutSyntax m loc t tdest+automaton mqi alphFld transRel' = Automaton mqi alph trans'+    where -- FIXME t is now Completable, in other functions we expect actions instead of transitions to be Completable.+          -- some alternatives: instead of forbidden, just throw an error (not nice), or add a separate class for transitions+    alph = Set.fromList $ Foldable.toList alphFld+    trans' q = Map.restrictKeys (transRel' q) alph `Map.union` setToList alph implicitDestination -- left-biased union+    setToList s f = Set.foldr (\k -> Map.insert k (f k)) Map.empty s++-- | Construct an automaton from an initial state and a transition mapping+automaton' :: (BoundedMonad m, Completable t, Ord t) => loc -> Set t -> (loc -> Map t (m (tdest, loc))) -> AutSyntax m loc t tdest+automaton' = automaton . BM.ordReturn++{- |+    The transition relation as a function. Note that this function is partial, and only defined for transition labels in the alphabet of the+    automaton.+-}+trans :: Ord t => AutSyntax m loc t tdest -> loc -> t -> m (tdest, loc)+trans aut loc t = case Map.lookup t (transRel aut loc) of+    Just x -> x+    Nothing -> error "transition function only defined for transition labels in the automaton alphabet"++---------------+-- interpret --+---------------++{- |+    Semantical automaton model. This model contains a reference to the syntactical automaton on which it is based,+    but it also contains a state configuration with semantical states.++    The difference between the locations from the syntactical model and the states from the semantical model depends+    on the automaton interpret. E.g. for a simple automaton model, states and locations may be the same, whereas a more+    complex automaton model may have states consisting of syntactical locations combined with valuations for data+    variables, clocks for timing, etc.+-}+data AutIntrpr m loc q t tdest act = AutInterpretation {+    stateConf :: m q,+    syntacticAutomaton :: AutSyntax m loc t tdest+    }++{- |+    Infer a semantical model from a syntactical model, based on the appropriate instance of the 'AutomatonSemantics' typeclass.+    Note that an automaton may be interpreted in multiple ways, so the type checker may need a hint on which semantical+    automaton is requested. This can be avoided by calling more specific, pre-typed variants of 'interpret' in+    "Lattest.Adapter.StandardAdapters".+-}+interpret :: (StepSemantics m loc q t tdest act, Ord q) => AutSyntax m loc t tdest -> (loc -> q) -> AutIntrpr m loc q t tdest act+interpret aut initState = AutInterpretation { stateConf = initState BM.<#> initConf aut, syntacticAutomaton = aut }++-- | The given model, in the given configuration.+inConfiguration :: AutIntrpr m loc q t tdest act -> m q -> AutIntrpr m loc q t tdest act+inConfiguration aut conf = aut {stateConf = conf}++-- | The Completable typeclass defines which types can be used as labels on transitions.+class Completable act where+    {- |+        Defines the implicit state configuration reached by a given transition label if that label is omitted from +        a syntactical automaton. E.g. if a state contains no outgoing transition for an output label, that label+        is often considered to map to the 'forbidden' state configuration.+    -}+    implicitDestination :: BoundedConfiguration m => act -> m any++class TransitionMapping t act where+    {- |+        Map an action to a matching transition. E.g. a concrete value on some channel that matches with the symbolic representation of that channel.+        'Nothing' indicates an action that occurs within a location, without explicit transition.+    -}+    asTransition :: Set t -> act -> Maybe t++{- |+    TransitionSemantics expresses that the interpret of a syntactic transition can be expressed in terms of actions. E.g. symbolic transitions with+    interaction variables that can be expressed in terms of concrete observed values.+-}+class (Ord t, Completable act, TransitionMapping t act, StateSemantics loc q) => TransitionSemantics loc q t tdest act | t act -> tdest where+    {- |+        Find the syntactic transition that applies for the given semantic action value, or alternatively a move within the location.+        The function may be partial, following the given alphabet.+    -}+    takeTransition :: (BoundedMonad m) => q -> Set t -> act -> (t -> m (tdest, loc)) -> Move m t tdest loc+    takeTransition q alph act trans' = case asTransition alph act of+        Nothing -> LocationMove $ BM.ordReturn $ asLoc q+        Just t -> TransitionMove (t, trans' t)++class (Ord t, Completable act, TransitionMapping t act, StateSemantics loc q) => IOTransitionSemantics loc q t tdest act | t act -> tdest where+    {- |+        Find the syntactic transition that applies for the given semantic action value, or alternatively a move within the location.+        The function may be partial, following the given alphabet.+    -}+    ioTakeTransition :: (BoundedMonad m, BooleanConfiguration m) => q -> Set t -> act -> (t -> m (tdest, loc)) -> IO (Move m t tdest loc)+    ioTakeTransition q alph act trans' = return $ case asTransition alph act of+        Nothing -> LocationMove $ BM.ordReturn (asLoc q)+        Just t -> TransitionMove (t, trans' t)++{- |+    Data structure needed to express that an automaton may transition from one location to another, but it may also 'transition'+    within a single state, e.g. the passing of time in a timed automaton.+-}+data Move m t tdest loc = TransitionMove (t, m (tdest, loc)) | LocationMove (m loc)++{- |+    StateSemantics expresses that the interpret of a syntactic location can be expressed in terms of state q. E.g. a location symbolic variables can be +    given in terms of valuations of these variables.+-}+class StateSemantics loc q where+    -- | from a state, extract the corresponding location+    asLoc :: q -> loc++{- |+    StepSemantics expresses that we can move through an automaton run with state semantics by applying the transition semantics+    The transition consists of two parts: one global part outside the configuration monad (e.g. describing the action that applies to that transition),+    described by the transition semantics, and a local part inside the monad, bound to the destination state (e.g. to update symbolic variables for a state).+-}+class (StateSemantics loc q, BoundedMonad m) => StepSemantics m loc q t tdest act where+    {- |+        Given the current state, an action and the transition matching that action, and a new location and local transition, produce the new state+        The case of no transition (i.e. no transition applies in the TransitionSemantics) can be used to move within a location.+    -}+    move :: q -> act -> Maybe (t, tdest) -> loc -> m q++type After m loc q t tdest act = (StepSemantics m loc q t tdest act, TransitionSemantics loc q t tdest act, Ord t)++{- |+    Take a step for the given action, according to the step semantics to move from one state configuration to another. May throw an AutomatonException.+-}+after :: (After m loc q t tdest act, Ord (m q), Ord q) => AutIntrpr m loc q t tdest act -> act -> AutIntrpr m loc q t tdest act+after aut act = runIdentity $ afterInternal takeTransitionId fmapId aut act+    where+    takeTransitionId :: (BoundedMonad m, TransitionSemantics loc q t tdest act) => q -> Set t -> act -> (t -> m (tdest, loc)) -> Identity (Move m t tdest loc)+    takeTransitionId q alph act' trans' = Identity $ takeTransition q alph act' trans'+    fmapId :: (BM.OrdFunctor f, Ord y) => (x -> Identity y) -> f x -> Identity (f y)+    fmapId f = Identity . BM.ordMap (runIdentity . f)++class IOAfter m loc q t tdest act where+    ioAfter :: AutIntrpr m loc q t tdest act -> act -> IO (AutIntrpr m loc q t tdest act)++-- tdest ~ () <=> LTS+instance (After m loc q t () act, Ord (m q), Ord q) => IOAfter m loc q t () act where+    ioAfter aut act = return $ after aut act++-- tdest ~ STStdest <=> STS+instance (StepSemantics m loc q t STStdest act, IOTransitionSemantics loc q t STStdest act, BooleanConfiguration m, Ord q, Ord t, Ord (m q), BM.OrdTraversable m) => IOAfter m loc q t STStdest act where+    ioAfter = afterInternal ioTakeTransition BM.ordTraverse++--takeTransition :: (BoundedMonad m) => q -> Set t -> act -> (t -> m (tdest, loc)) -> Move m t tdest loc+--ioTakeTransition :: (BoundedMonad m) => q -> Set t -> act -> (t -> m (tdest, loc)) -> IO (Move m t tdest loc)++-- distributeMonadOverFoldable :: (Functor m, Foldable m, Monad execM, Ord x) => (x -> execM y) -> m x -> execM (m y)+-- fmapInternal?? :: (Functor m, Monad execM) => (x -> execM y) -> m x -> execM (m y)+afterInternal :: (StepSemantics m loc q t tdest act, Monad execM, Ord t, Ord q, Ord (m q)) =>+    (q -> Set t -> act -> (t -> m (tdest, loc)) -> execM (Move m t tdest loc)) ->+    ((q -> execM (m q)) -> m q -> execM (m (m q))) ->+    AutIntrpr m loc q t tdest act -> act -> execM (AutIntrpr m loc q t tdest act)+afterInternal internalTakeTransition fmapmq intrpr act' = do+    let aut = syntacticAutomaton intrpr+        toNewStateConfig = afterInternal' internalTakeTransition (alphabet aut) (transRel aut) act'+    stateConf' <- toNewStateConfig `fmapmq` stateConf intrpr+    return $ intrpr { stateConf = BM.ordJoin stateConf' }+{-+after :: (StepSemantics m loc q t tdest act, Ord q, Ord (m q)) => AutIntrpr m loc q t tdest act -> act -> AutIntrpr m loc q t tdest act+after intrpr act' = +    let aut = syntacticAutomaton intrpr+        stateConf' = BM.ordBind (stateConf intrpr) (after' (alphabet aut) (transRel $ aut) act')+    in intrpr { stateConf = stateConf' }+    -}++afterInternal' :: (StepSemantics m loc q t tdest act, Ord t, Ord q, Ord (m q), Monad execM) =>+    (q -> Set t -> act -> (t -> m (tdest, loc)) -> execM (Move m t tdest loc)) ->+    Set t -> (loc -> Map t (m (tdest, loc))) -> act -> q -> execM (m q)+afterInternal' internalTakeTransition alph transMap act q = do+    t <- internalTakeTransition q alph act (lookupAction $ transMap $ asLoc q)+    --Monad.join <$> case t of+    return $ BM.ordJoin $ case t of+        LocationMove mloc -> move q act (nothingTTdest transMap) BM.<#> mloc+            where+            -- ugly solution to get a Nothing of the type (Maybe (t, tdest)) without ScopedTypeVariables+            nothingTTdest :: (x1 -> Map t (x2 (tdest, x3))) -> Maybe (t, tdest)+            nothingTTdest _ = Nothing+        TransitionMove (t', mtdestloc) -> moveAlongTransition q act t' BM.<#> mtdestloc+            where+            moveAlongTransition :: (StepSemantics m loc q t tdest act) => q -> act -> t -> (tdest, loc) -> m q+            moveAlongTransition q' act' t'' (tdest, loc) = move q' act' (Just (t'', tdest)) loc+        where+        lookupAction :: Ord k => Map k a -> k -> a+        lookupAction m k = case Map.lookup k m of+            Just v -> v+            Nothing -> throw $ ActionOutsideAlphabet callStack+{-+after' :: (StepSemantics m loc q t tdest act) => Set t -> (loc -> Map t (m (tdest, loc))) -> act -> q -> m q+after' alph transMap act q = BM.ordJoin $ case takeTransition (asLoc q) alph act (lookupAction $ transMap $ asLoc q) of+    LocationMove mloc -> move q act (nothingTTdest transMap) BM.<#> mloc+        where+         -- ugly solution to get a Nothing of the type (Maybe (t, tdest)) without ScopedTypeVariables+        nothingTTdest :: (x1 -> Map t (x2 (tdest, x3))) -> Maybe (t, tdest)+        nothingTTdest _ = Nothing+    TransitionMove (t, mloc) -> moveAlongTransition q act t BM.<#> mloc+        where+        moveAlongTransition q act t (tdest, loc) = move q act (Just (t, tdest)) loc+    where+    lookupAction :: Ord k => Map k a -> k -> a+    lookupAction m k = case Map.lookup k m of+        Just v -> v+        Nothing -> throw $ ActionOutsideAlphabet callStack+-}++-- | Take a sequence of transitions for the given actions.+afters :: (StepSemantics m loc q t tdest act, TransitionSemantics loc q t tdest act, Ord q, Ord (m q)) => AutIntrpr m loc q t tdest act -> [act] -> AutIntrpr m loc q t tdest act+afters aut [] = aut+afters aut (act:acts) = aut `after` act `afters` acts++-- | Exceptions that can occur when working with automata.+newtype AutomatonException+    -- | Thrown during a computation of `after` for an action outside the automaton alphabet.+    = ActionOutsideAlphabet CallStack+    deriving (Show)+instance Eq AutomatonException where+    (==) (ActionOutsideAlphabet _) (ActionOutsideAlphabet _) = True+instance Ord AutomatonException where+    (<=) (ActionOutsideAlphabet _) (ActionOutsideAlphabet _) = True++instance Exception AutomatonException++------------------------------------------------------------------+-- utility function to obtain the menu of outgoing transitions --+------------------------------------------------------------------+-- note: this only shows the transitions that are syntactically present in the automaton, so e.g. not quiescence, including underspecified/forbidden transitions+transMenu :: (Foldable m, BM.OrdFunctor m, Ord t) => AutSyntax m mloc t tdest -> Set t+transMenu aut = let+    stateToMenu = Set.fromList . Map.keys . transRel aut+    in Set.unions $ stateToMenu BM.<#> initConf aut++{-|+    The class of automata with a finite list of concrete actions matching to outgoing transitions for every state.+    This property is useful for e.g. test selection.+-}+class TransitionMapping t act => FiniteMenu t act where+    -- menu of actions that are semantically present in the automaton, including underspecified/forbidden transitions+    asActions :: t -> [act]+    locationActions :: AutSyntax m mloc t tdest -> [act]++actionMenu :: (Foldable m, Ord t, Ord act, FiniteMenu t act, BoundedMonad m) => AutSyntax m mloc t tdest -> [act]+actionMenu aut = (locationActions aut ++) $ concat $ BM.ordMap asActions $ Set.toList $ transMenu aut++-- | Menu of specified actions that are semantically present in the automaton.+specifiedMenu :: (StepSemantics m loc q t tdest act, TransitionSemantics loc q t tdest act, Foldable m, Ord act, Ord q, Ord (m q), FiniteMenu t act)+    => AutIntrpr m loc q t tdest act -> [act]+specifiedMenu aut = [act | act <- actionMenu $ syntacticAutomaton aut, isSpecified $ stateConf $ aut `after` act]++-----------------------------------------------------------------------------------------------+-- special case where the semantic states and actions are directly represented syntactically --+-----------------------------------------------------------------------------------------------++instance {-# OVERLAPPABLE #-} (Completable act) where+    implicitDestination _ = forbidden++instance TransitionMapping act act where+    asTransition _ = Just++instance (Ord act, Completable act) => TransitionSemantics q q act () act++instance FiniteMenu act act where+    asActions t = [t]+    locationActions _ = []++instance StateSemantics q q where+    asLoc = id++instance (TransitionSemantics q q t () act, BoundedMonad m) => StepSemantics m q q t () act where+    move _ _ _ = BM.ordReturn++----------------+-- quiescence --+----------------+instance (Completable (IOAct i o)) where+    implicitDestination (Out _) = forbidden+    implicitDestination _ = underspecified++instance TransitionMapping (IOAct i o) (IOSuspAct i o) where+    asTransition _ (Out Quiescence) = Nothing+    asTransition _ other = Just $ fromSuspended other++instance (Ord i, Ord o) => TransitionSemantics q q (IOAct i o) () (IOSuspAct i o) where+    -- TODO this takeTransition only detects plain 'forbidden', not if hidden in e.g. symbolic locations+    takeTransition loc alph (Out Quiescence) m = LocationMove $ if hasQuiescence (Map.fromSet m alph) then BM.ordReturn loc else forbidden+    takeTransition _ _ act m = TransitionMove (fromSuspended act, m $ fromSuspended act)++instance FiniteMenu (IOAct i o) (IOSuspAct i o) where+    asActions t = [asSuspended t]+    locationActions _ = [Out Quiescence]++hasQuiescence :: BoundedMonad m => Map (IOAct i o) (m (tdest, loc)) -> Bool+hasQuiescence m = not $ any (isOutput . fst &&& not . isForbidden . snd) (Map.toList m)++-------------------+-- input-failure --+-------------------++instance TransitionMapping (IOAct i o) (IFAct i o) where+    asTransition _ (In (InputAttempt(_, False))) = Nothing+    asTransition _ other = Just $ fromInputAttempt other++instance (Ord i, Ord o) => TransitionSemantics  q q (IOAct i o) () (IFAct i o) where+    -- TODO this takeTransition only detects plain 'forbidden', not if hidden in e.g. symbolic locations+    takeTransition _ _ (In (InputAttempt(i, False))) m =+        let mtdestloc = m $ In i+        in LocationMove $ if isSpecified mtdestloc+            then forbidden -- if ?i is specified, then the failure of ?i is forbidden+            else underspecified -- input failure is not repetitive: it is allowed, and nothing can be done afterwards, i.e., underspecified+    takeTransition _ _ act' m = TransitionMove (fromInputAttempt act', m $ fromInputAttempt act')++instance FiniteMenu (IOAct i o) (IFAct i o) where+    asActions t = [asInputAttempt t]+    locationActions _ = []++--------------------------------+-- input-failure + quiescence --+--------------------------------+-- Ideally this would automatically follow from the above two interpretations stacked to avoid the boilerplate below, but that is a hassle++instance TransitionMapping (IOAct i o) (SuspendedIF i o) where+    asTransition _ (In (InputAttempt(_, False))) = Nothing+    asTransition _ (Out Quiescence) = Nothing+    asTransition _ other = Just $ fromSuspendedInputAttempt other++instance (Ord i, Ord o) => TransitionSemantics q q (IOAct i o) () (SuspendedIF i o) where+    -- TODO this takeTransition only detects plain 'forbidden', not if hidden in e.g. symbolic locations+    takeTransition _ _ (In (InputAttempt(i, False))) m =+        let mtdestloc = m $ In i+        in LocationMove $ if isSpecified mtdestloc+            then forbidden -- if ?i is specified, then the failure of ?i is forbidden+            else underspecified -- input failure is not repetitive: it is allowed, and nothing can be done afterwards, i.e., underspecified++    takeTransition loc alph (Out Quiescence) m = LocationMove $ if hasQuiescence (Map.fromSet m alph) then forbidden else BM.ordReturn loc+    takeTransition _ _ act m = TransitionMove (fromSuspendedInputAttempt act, m $ fromSuspendedInputAttempt act)++instance FiniteMenu (IOAct i o) (SuspendedIF i o) where+    asActions t = [asSuspendedInputAttempt t]+    locationActions _ = [Out Quiescence]++--------------------------------+-- STS interpretation --+--------------------------------++data IntrpState a = IntrpState a Valuation deriving (Eq, Ord)++instance Show a => Show (IntrpState a) where+    show (IntrpState a v) = show (a,v)++newtype STStdest = STSLoc (SymGuard,VarModel) deriving (Eq, Ord)++stsTLoc :: SymGuard -> VarModel -> STStdest+stsTLoc g a = STSLoc (g,a)++instance Show STStdest where+    show (STSLoc (g,a)) =  show g ++ ", " ++ show a++instance Completable (IOGateValue i o) where+    implicitDestination (GateValue g _) = implicitDestination g++instance Completable (IOSymInteract i o) where+    implicitDestination (SymInteract g _ ) = implicitDestination g++instance StateSemantics a (IntrpState a) where+    asLoc (IntrpState l _) = l++instance (Ord g, TransitionMapping g g') => TransitionMapping (SymInteract g) (GateValue g') where+    asTransition interactions (GateValue g vals) = do+        let ts = Set.map interactionGate interactions+        ig' <- asTransition ts g+        case List.find (\(SymInteract ig _) -> ig == ig') (Set.toList interactions) of+            Nothing -> errorWithoutStackTrace "gate not in STS alphabet"+            Just i@(SymInteract _ vars) ->+                if List.length vals /= List.length vars+                    then errorWithoutStackTrace $+                      "nr of values unequal to nr of parameters: " <> show (List.length vals) <> " values and " <> show (List.length vars) <> " variables"+                    else if List.all (\(var,val) -> varType var == constType val) (zip vars vals)+                            then Just i+                            else errorWithoutStackTrace $+                              "type of variable and value do not match. Variables: " <> show vars <> ", Values: " <> show vals++instance (Completable (GateValue g'), Ord g, TransitionMapping g g') => TransitionSemantics loc (IntrpState loc) (SymInteract g) STStdest (GateValue g') where++instance (Completable (GateValue g'), BoundedMonad m) => StepSemantics m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g') where+    move (IntrpState _l1 stateValuation) gv@(GateValue _ gateVals) (Just (SymInteract _ gateVars, STSLoc (guard,assign))) l2 =+        let gateValuation = buildGateValuation gateVars gateVals+            -- valuation = Map.foldrWithKey (\x xval m -> insertIntoValuation x xval m) gateValuation stateValuation+            valuation = fromConstantsMap $ toConstantsMap stateValuation `Map.union` toConstantsMap gateValuation+        in if not $ evalBool valuation guard+            then implicitDestination gv+            else let stateValuation2 = Map.mapWithKey (\var val -> assignNewValue var val valuation assign) $ toConstantsMap stateValuation+                 in BM.ordReturn $ IntrpState l2 $ fromConstantsMap stateValuation2+        where+        assignNewValue :: Variable -> Constant -> Valuation -> VarModel -> Constant+        -- the following case distinctino could be removed if constants were also typed+        assignNewValue var@(Variable _ IntType) oldVal val' assign' = maybe oldVal (evalVal val') (assignedExpr var assign' :: Maybe (Expr Integer))+        assignNewValue var@(Variable _ BoolType) oldVal val' assign' = maybe oldVal (evalVal val') (assignedExpr var assign' :: Maybe (Expr Bool))+        assignNewValue var@(Variable _ StringType) oldVal val' assign' = maybe oldVal (evalVal val') (assignedExpr var assign' :: Maybe (Expr String))+        assignNewValue var@(Variable _ FloatType) oldVal val' assign' = maybe oldVal (evalVal val') (assignedExpr var assign' :: Maybe (Expr Double))+    move (IntrpState _ stateValuation) _ Nothing l2 = BM.ordReturn (IntrpState l2 stateValuation) -- TODO check if this is correct+buildGateValuation :: [Variable] -> [Constant] -> Valuation+--buildGateValuation gateVars gateVals = List.foldr (\(gateVar,gateVal) m -> insertIntoValuation gateVar gateVal m) (Map.empty) (zip gateVars gateVals)+buildGateValuation gateVars gateVals = assignValues $ (\(gateVar,gateVal) m -> insertIntoValuation gateVar gateVal m) <$> zip gateVars gateVals+evalVal :: (ConstType t, Assignable t) => Valuation -> Expr t -> Constant+evalVal valuation e = case eval $ substConst valuation e of+    Right v -> toConst v+    Left m -> error $ "evalVal: " ++ m+evalBool :: Valuation -> Expr Bool -> Bool+evalBool valuation = toBool . evalVal valuation++--------------------+-- STS quiescence --+--------------------+instance (Ord i, Ord o) => IOTransitionSemantics loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i o) where+    -- TODO this takeTransition only detects plain 'forbidden', not if hidden in e.g. symbolic locations+    -- TODO do something with the values (now "_"), even if just throwin an exception if non-empty+    ioTakeTransition (IntrpState loc stateVal) alph (GateValue (Out Quiescence) _) m = do+        qui <- hasSymbolicQuiescence stateVal (Map.fromSet m alph)+        return $ LocationMove $ if qui then BM.ordReturn loc else forbidden+    ioTakeTransition q alph act m = return $ takeTransition q alph (fromSuspended <$> act) m++hasSymbolicQuiescence :: (BoundedMonad m, BooleanConfiguration m) => Valuation -> Map (IOSymInteract i o) (m (STStdest, loc)) -> IO Bool+hasSymbolicQuiescence stateVal m = do+    let syntacticallySpecifiedOutputs = filter (isOutputInteract . fst &&& not . isForbidden . snd) (Map.toList m)+        outputsAndCombinedGuards = second (combineGuards . BM.ordMap (substituteInGuard stateVal . tdestlocToGuard)) <$> syntacticallySpecifiedOutputs+    -- FIXME this should not solve sequentially, flattening the full list to a single guard is potentially more efficient (e.g. when the last guard in the list is trivially true)+    Maybe.isNothing <$> runSMT (solveAnySequential outputsAndCombinedGuards)+    where+    tdestlocToGuard (STSLoc (guard, _), _) = guard++-----------------------+-- STS input-failure --+-----------------------+instance (Ord i, Ord o) => IOTransitionSemantics loc (IntrpState loc) (IOSymInteract i o) STStdest (IFGateValue i o) where+    ioTakeTransition (IntrpState _ stateVal) alph (GateValue (In (InputAttempt(i, False))) gateVals) m =+        case asTransition alph (coerceIO (GateValue (In (InputAttempt (i, True))) gateVals) alph) of+            Nothing -> error "TransitionSemantics IFGateValue: error"+            Just interact'@(SymInteract _ gateVars) ->+                let gateVal = buildGateValuation gateVars gateVals+                    mtdestloc = m interact'+                    guard = combineGuards $ tdestlocToGuard BM.<#> mtdestloc+                    guardVal = evaluateGuard $ substituteInGuard gateVal $ substituteInGuard stateVal guard+                in return $ LocationMove $ if isSpecified mtdestloc && guardVal+                    then forbidden+                    else underspecified+        where+        tdestlocToGuard (STSLoc (guard, _), _) = guard+        coerceIO :: IFGateValue i o -> Set.Set (IOSymInteract i o) -> IFGateValue i o+        coerceIO = const+    ioTakeTransition q alph gateValue m = return $ takeTransition q alph (fromInputAttempt <$> gateValue) m++------------------------------------+-- STS input-failure + quiescence --+------------------------------------+-- Ideally this would automatically follow from the above two interpretations stacked to avoid the boilerplate below, but that is a hassle+instance (Ord i, Ord o) => IOTransitionSemantics loc (IntrpState loc) (IOSymInteract i o) STStdest (SuspendedIFGateValue i o) where+    ioTakeTransition (IntrpState loc stateVal) alph (GateValue (Out Quiescence) _) m = do+        qui <- hasSymbolicQuiescence stateVal (Map.fromSet m alph)+        return $ LocationMove $ if qui then BM.ordReturn loc else forbidden+    ioTakeTransition (IntrpState _ stateVal) alph (GateValue (In (InputAttempt(i, False))) gateVals) m =+        case asTransition alph (coerceIO (GateValue (In (InputAttempt (i, True))) gateVals) alph) of+            Nothing -> error "TransitionSemantics IFGateValue: error"+            Just interact'@(SymInteract _ gateVars) ->+                let gateVal = buildGateValuation gateVars gateVals+                    mtdestloc = m interact'+                    guard = combineGuards $ tdestlocToGuard BM.<#> mtdestloc+                    guardVal = evaluateGuard $ substituteInGuard gateVal $ substituteInGuard stateVal guard+                in return $ LocationMove $ if isSpecified mtdestloc && guardVal+                    then forbidden+                    else underspecified+        where+        tdestlocToGuard (STSLoc (guard, _), _) = guard+        coerceIO :: IFGateValue i o -> Set.Set (IOSymInteract i o) -> IFGateValue i o+        coerceIO = const+    ioTakeTransition q alph gateValue m = return $ takeTransition q alph (fromSuspendedInputAttempt <$> gateValue) m++-------------------------+-- Auxiliary functions --+-------------------------++{- |+    Compute the set of locations that is syntactically reachable from the initial location configuration. See `reachableFrom`.+-}+reachable :: (Ord loc, Foldable m) => AutSyntax m loc t tdest -> Set loc+reachable aut = reachableFrom aut $ initConf aut++{- |+    Compute the set of locations that is syntactically reachable from the given locations.+    +    Note that this not involve any interpretation of the automaton, e.g. if a location of symbolic automaton is only reachable via a transition with+    a guard that is always `False`, then that location is still considered to be reachable, even if a symbolic interpretation of that automaton+    can never reach that location for any trace of concrete values.+-}+reachableFrom :: (Ord loc, Foldable m, Foldable f) => AutSyntax m loc t tdest -> f loc -> Set loc+reachableFrom aut locations = reachableFrom' Set.empty $ Set.fromList $ Foldable.toList locations+    where+    reachableFrom' acc boundary = case takeArbitrary boundary of+        Nothing -> acc -- done, no more new states to explore+        Just (q, boundaryRem) -> -- explore the states reached by transitions from q+            let ts = transRel aut q+                qs = Set.fromList $ concatMap (fmap snd . Foldable.toList) $ Map.elems ts+                new = qs `Set.difference` acc+                acc' = acc `Set.union` new+                boundary' = boundaryRem `Set.union` new+            in reachableFrom' acc' boundary'++++prettyPrint :: (Show (m (tdest, loc)), Show (m loc), Show loc, Show t, Ord loc, Foldable m) => AutSyntax m loc t tdest -> String+prettyPrint aut = prettyPrintFrom aut (initConf aut)++prettyPrintFrom :: (Show (m (tdest, loc)), Show (m loc), Show loc, Show t, Ord loc, Foldable m, Foldable f) => AutSyntax m loc t tdest -> f loc -> String+prettyPrintFrom aut fromLocs = "initial location configuration: " ++ printInitial ++ "\nlocations: " ++ printLocations ++ "\ntransitions:\n" ++ printTransitions+    where+    locations = Set.toList $ reachableFrom aut fromLocs+    printInitial = show $ initConf aut+    printLocations = List.intercalate ", " (show <$> locations)+    printTransitions = List.intercalate "\n" (printTransitionsFrom <$> locations)+    printTransitionsFrom q = List.intercalate "\n" (printTransition q <$> Map.toList (transRel aut q))+    printTransition q (t, mt) = show q ++ "  ――" ++ show t ++ "⟶  " ++ show mt++prettyPrintIntrp :: (Show (m (tdest, loc)), Show (m loc), Show loc, Show (m q), Show t, Ord loc, Foldable m) => AutIntrpr m loc q t tdest act -> String+prettyPrintIntrp intrp = "current state configuration: " ++ printStateConf ++ "\n" ++ printAut+    where+    printStateConf = show $ stateConf intrp+    printAut = prettyPrint $ syntacticAutomaton intrp++
+ src/Lattest/Model/BoundedMonad.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ConstraintKinds #-}+++{- |+    A /bounded monad/ is a type constructor which represents the observable perspective on the state of an automaton, also called a+    /state configuration/. A system will internally have a state, but this state can not always be observed or inferred for an external viewer. To+    model the difference between internal and observable state, we define automata as having a type of internal state, say q, and+    an observable state configuration over q.+    +    In this module, we define two such state configurations:+    +    * deterministic state configurations, where every behaviour leads to a single state,+    * distributive lattices, or positive boolean formulas, where the observable behaviour is expressed as a logical expression over states.+    +    Here, 'observed behaviour' is formally a trace or sequence of observable actions. Thus, after a trace, the system is+    in a state configuration over states. The state configuration is computed by taking transitions, following the monadic interpret +    of the state configuration. If the automaton does not exhibit a given trace of actions, then the state configuration after+    that trace is either 'forbidden' or 'underspecified'. Here, 'forbidden' expresses that the automaton does not allow the+    given trace, whereas 'underspecified' expresses that the automaton does not specify the trace, hence the trace is allowed.+    +    The name 'bounded monad' is based on bounded lattices, which have a top and bottom element. For more details on the use of top and bottom in+    state configurations, see+    +    * [/Ramon Janssen/, Refinement and partiality for model-based testing (Doctoral dissertation), 2022, Chapter 4](https://repository.ubn.ru.nl/bitstream/handle/2066/285020/285020.pdf)++-}++module Lattest.Model.BoundedMonad (+-- * State configurations+-- ** Deterministic+Det(..),+-- ** Distributive lattice in CNF+FreeLattice(FreeLattice),+atom,+top,+bot,+-- * Specifiednesss+Specifiedness(..),+BoundedConfiguration,+specifiedness,+forbidden,+underspecified,+isForbidden,+isUnderspecified,+-- ** Auxiliary Specifiedness functions+isAllowed,+isSpecified,+isIndefinite,+isConclusive,+-- ** Utility types+BoundedMonad,+BoundedFunctor,+-- ** General non-determinism+JoinSemiLattice,+MeetSemiLattice,+(\/),+(/\),+-- ** Mapping between lattices and boolean expressions+BooleanConfiguration,+asExpr,+asDualExpr,+-- ** 'Data.OrdMonad' re-export, for convenience.+module OM,+joins,+meets,+disjunction,+(\$/),+conjunction,+(/$\)+)+where++import qualified Lattest.Model.Symbolic.Expr as E++import qualified Data.List as List+import qualified Data.Set as Set+import Data.OrdMonad as OM+++-- | Deterministic state configuration. This means that an automaton is either in a single state, or in an explicit forbidden configuration, or in an explicit underspecified configuration.+data Det q = Det q | ForbiddenDet | UnderspecDet deriving (Ord, Eq)++instance BoundedConfiguration Det where+    isForbidden ForbiddenDet = True+    isForbidden _ = False+    isUnderspecified UnderspecDet = True+    isUnderspecified _ = False+    forbidden = ForbiddenDet+    underspecified = UnderspecDet++instance Functor Det where+    fmap f (Det s) = Det (f s)+    fmap _ UnderspecDet = UnderspecDet+    fmap _ ForbiddenDet = ForbiddenDet++instance Applicative Det where+    Det f <*> (Det s) = Det (f s)+    ForbiddenDet <*> _ = ForbiddenDet+    UnderspecDet <*> _ = UnderspecDet+    _ <*> ForbiddenDet = ForbiddenDet+    _ <*> UnderspecDet = UnderspecDet+    pure = Det++instance Monad Det where+    Det s >>= f = f s+    ForbiddenDet >>= _ = ForbiddenDet+    UnderspecDet >>= _ = UnderspecDet++instance Foldable Det where+    foldr f q (Det q') = f q' q+    foldr _ q _ = q++instance Show a => Show (Det a) where+    show (Det a) = show a+    show ForbiddenDet = "-forbidden-"+    show UnderspecDet = "-underspecified-"++{-|+    Free distributive lattice, or a positive boolean formula, in CNF-format. +-}+newtype FreeLattice a = FreeLattice (Set.Set (Set.Set a)) deriving  (Eq, Ord, Foldable)++-- | A single state embedded in a free distributive lattice.+atom :: a -> FreeLattice a+atom = ordReturn++-- | The free distributive lattice element ⊥, or false.+bot :: FreeLattice a+bot = forbidden++-- | The free distributive lattice element ⊤, or true.+top :: FreeLattice a+top = underspecified++-- | Combine a collection of FreeLattices using '(/\)'+meets :: (Foldable f, Ord a) => f (FreeLattice a) -> FreeLattice a+meets = foldr (/\) top++-- | Combine a collection of FreeLattices using '(\/)'+joins :: (Foldable f, Ord a) => f (FreeLattice a) -> FreeLattice a+joins = foldr (\/) bot++-- | Combine a collection of states using '(/\)'+conjunction :: (Functor f, Foldable f, Ord a) => f a -> FreeLattice a+conjunction = meets . fmap atom++-- | Synonym for 'conjunction'+(/$\) :: (Functor f, Foldable f, Ord a) => f a -> FreeLattice a+(/$\) = conjunction++-- | Combine a collection of states using '(\/)'+disjunction :: (Functor f, Foldable f, Ord a) => f a -> FreeLattice a+disjunction = joins . fmap atom++-- | Synonym for 'disjunction'+(\$/) :: (Functor f, Foldable f, Ord a) => f a -> FreeLattice a+(\$/) = disjunction++instance BoundedConfiguration FreeLattice where+    isForbidden (FreeLattice x) = any Set.null x+    isUnderspecified (FreeLattice x) = Set.null x+    forbidden = FreeLattice $ Set.singleton Set.empty+    underspecified = FreeLattice Set.empty++instance OM.OrdMonad FreeLattice where+    ordBind (FreeLattice x) f = FreeLattice $ cnfJoin $ Set.map (Set.map f1) x+        where+            f1 y = let FreeLattice z = f y in z+    ordReturn x = FreeLattice  $ Set.singleton $ Set.singleton x++cnfJoin :: (Ord a) => Set.Set (Set.Set (Set.Set (Set.Set a))) -> Set.Set (Set.Set a)+cnfJoin = reduceAll . Set.map Set.unions . Set.unions . Set.map nAryCartesianProduct+    where+    -- some possible optimizations: 1) don't compare every element to and 2) use the ordering on sets to avoid half of the comparisons, 3) ensure that this ordering is such that absorbing/neutral elements are compared first and avoid more work in that case+    reduceAll sets = Set.filter (not . isProperSupersetOfAny sets) sets++nAryCartesianProduct :: (Ord a) => Set.Set (Set.Set a) -> Set.Set (Set.Set a)+nAryCartesianProduct j = Set.map Set.fromList $ Set.fromList $ sequence $ Set.toList $ Set.map Set.toList j++isProperSupersetOfAny :: Ord a => Set.Set (Set.Set a) -> Set.Set a -> Bool+isProperSupersetOfAny sets a = any (isProperSupersetOf a) (Set.toList sets)+    where+    isProperSupersetOf :: Ord a => Set.Set a -> Set.Set a -> Bool+    isProperSupersetOf set potentialSubset = (potentialSubset `Set.isSubsetOf` set) && not (set `Set.isSubsetOf` potentialSubset)++instance OM.OrdFunctor FreeLattice where+    ordMap f (FreeLattice x) = FreeLattice $ Set.map (Set.map f) x++instance Ord a => JoinSemiLattice (FreeLattice a) where+    (FreeLattice x) \/ (FreeLattice y) = FreeLattice $ Set.map Set.unions $ nAryCartesianProduct $ Set.fromList [x,y]++instance Ord a => MeetSemiLattice (FreeLattice a) where+    (FreeLattice x) /\ (FreeLattice y) =+        let x' = Set.filter (not . isProperSupersetOfAny y) x+            y' = Set.filter (not . isProperSupersetOfAny x) y+        in FreeLattice (x' `Set.union` y')++instance Show a => Show (FreeLattice a) where+    show l+        | isForbidden l = "⊥"+        | isUnderspecified l = "⊤"+    show (FreeLattice x) = case Set.toList x of+            [conjunct] -> List.intercalate " ∨ " $ show <$> Set.toList conjunct+            conjuncts -> List.intercalate " ∧ " $ showDisjunct <$> conjuncts+        where+        showDisjunct :: Show a => Set.Set a -> String+        showDisjunct y = case Set.toList y of+            [e] -> show e+            disjuncts -> "(" ++ List.intercalate " ∨ " (show <$> disjuncts) ++ ")"++{-|+    Specifiednesss describe wether behaviour (a sequence of actions) is allowed a stateful specification model. 'Forbidden' describes that+    behaviour is not allowed, not is any subsequent behaviour. 'Underspecified' describes that behaviour is allowed and any subsequent+    behaviour is also allowed. 'Indefinite' means that the behaviour is allowed, and subsequent behaviour may be forbidden, underspecified,+    or may again be 'Indefinite'. +-}+data Specifiedness = Underspecified | Forbidden | Indefinite deriving (Eq, Ord, Show, Read)++{-|+    Specifiedness configurations are state configurations which have a representation for forbidden and underspecified configurations.+-}+class BoundedConfiguration m where+    forbidden :: m t -- ^ The forbidden state configuration. +    underspecified :: m t -- ^ The underspecified state configuration.+    isForbidden :: m t -> Bool -- ^ Is this state configuration forbidden?+    isUnderspecified :: m t -> Bool -- ^ Is this state configuration underspecified?++-- | Extract the current 'Specifiedness' from a bounded monad.+specifiedness :: BoundedConfiguration m => m t -> Specifiedness+specifiedness c+    | isForbidden c = Forbidden+    | isUnderspecified c = Underspecified+    | otherwise = Indefinite++-- | Is the configuration a representation of the 'Indefinite' specifiedness?+isIndefinite :: (BoundedConfiguration m) => m t -> Bool+isIndefinite p = specifiedness p == Indefinite++-- | Is the configuration a representation of "definitive", i.e., 'Forbidden' or 'Underspecified'?+isConclusive :: (BoundedConfiguration m) => m t -> Bool+isConclusive p = specifiedness p /= Indefinite++-- | Is the configuration a representation of "allowed", i.e., 'Indefinite' or 'Underspecified'?+isAllowed :: (BoundedConfiguration m) => m t -> Bool+isAllowed = not . isForbidden++-- | Is the configuration a representation of "specified", i.e., 'Indefinite' or 'Forbidden'?+isSpecified :: (BoundedConfiguration m) => m t -> Bool+isSpecified = not . isUnderspecified++-- | Abbreviation for types which are both bounded configurations and Monads.+type BoundedMonad m = (BoundedConfiguration m, OM.OrdMonad m)++-- | Abbreviation for types which are both bounded configurations and Functors.+type BoundedFunctor m = (BoundedConfiguration m, OM.OrdFunctor m)++-- | Semi-lattices with a binary join ('or') operation+class JoinSemiLattice a where+    (\/) :: a -> a -> a++-- | Semi-lattices with a binary meet ('and') operation+class MeetSemiLattice a where+    (/\) :: a -> a -> a++--this would be very sensible but it confuses the compiler greatly. Maybe the UndecidableInstances and Overlapping language extensions don't like each other?+--instance Lattice a => JoinSemiLattice a where+--    join = (L.\/)++class BooleanConfiguration m where -- TODO: possibly this class can be less ad-hoc, e.g. via some lattice-theoretic concept+    asExpr :: m (E.Expr Bool) -> E.Expr Bool++instance BooleanConfiguration Det where+    asExpr (Det q) = q+    asExpr ForbiddenDet = E.sFalse+    asExpr UnderspecDet = E.sTrue++instance BooleanConfiguration FreeLattice where+    asExpr (FreeLattice x) = Set.foldr (E..&&) E.sTrue $ Set.map (Set.foldr (E..||) E.sFalse) x++asDualExpr :: (OrdFunctor m, BooleanConfiguration m) => m (E.Expr Bool) -> E.Expr Bool+asDualExpr m = E.sNot $ asExpr $ E.sNot OM.<#> m++instance Traversable Det where+  sequenceA (Det a) = Det <$> a+  sequenceA ForbiddenDet = pure ForbiddenDet+  sequenceA UnderspecDet = pure UnderspecDet+
+ src/Lattest/Model/Internal/NonDeterministic.hs view
@@ -0,0 +1,109 @@+{- |+   Non-deterministic model definitions, where observable behaviour may lead to a set of states.+   These are equivalent to using Lattices with only `(\/)`, and defined in this separate module+   because `(/\)` is more often the intended meaning.+-}+module Lattest.Model.Internal.NonDeterministic (+  NonDet(..),+  nonDet,+  nonDetConcTransFromListRel+) where+import qualified Data.Set as Set+import Lattest.Model.BoundedMonad (BoundedConfiguration (..), BooleanConfiguration (..), JoinSemiLattice (..), OrdFunctor (..), OrdMonad (..))+import Lattest.Model.Symbolic.Expr (sOr, sTrue)+import Lattest.Model.Automaton (Completable (..))+import Data.Map (Map)+import Data.Maybe (fromJust, fromMaybe)+import Data.OrdMonad ((<#>))+import qualified Data.Map as Map++-- | Non-deterministic state configuration. This means that an automaton non-deterministically in a number of states, where zero states indicates the forbidden configuration, or in an explicit underspecified configuration.+data NonDet q = NonDet (Set.Set q) | UnderspecNonDet++nonDet :: Ord q => [q] -> NonDet q+nonDet = NonDet . Set.fromList++instance BoundedConfiguration NonDet where+    isForbidden (NonDet s) = Set.null s+    isForbidden _ = False+    isUnderspecified UnderspecNonDet = True+    isUnderspecified _ = False+    forbidden = NonDet Set.empty+    underspecified = UnderspecNonDet++instance OrdFunctor NonDet where+    ordMap f (NonDet ss) = NonDet $ ordMap f ss+    ordMap _ UnderspecNonDet = UnderspecNonDet++instance OrdMonad NonDet where+    ordBind (NonDet ss) f = foldr (\/) (NonDet Set.empty) $ Set.map f ss+    ordBind UnderspecNonDet _ = UnderspecNonDet+    ordReturn s = NonDet $ Set.singleton s++instance Foldable NonDet where+    foldr f q (NonDet qs) = foldr f q qs+    foldr _ q _ = q++instance Show a => Show (NonDet a) where+    show (NonDet a)+        | Set.null a = "⊥"+        | otherwise = show $ Set.toList a+    show UnderspecNonDet = "⊤"++instance Ord a => Eq (NonDet a) where+    UnderspecNonDet == UnderspecNonDet = True+    (NonDet q1) == (NonDet q2) = q1 == q2+    _ == _ = False++instance Ord a => Ord (NonDet a) where+    _ <= UnderspecNonDet = True+    UnderspecNonDet <= _ = False+    (NonDet q1) <= (NonDet q2) = q1 <= q2++instance (Ord a) => JoinSemiLattice (NonDet a) where+    (\/) (NonDet q1) (NonDet q2) = NonDet (Set.union q1 q2)+    (\/) _ _ = UnderspecNonDet -- underspecification acts as top, so is absorbing w.r.t. join++instance BooleanConfiguration NonDet where+    asExpr (NonDet qs) = sOr qs+    asExpr UnderspecNonDet = sTrue++{- |+    Create a non-deterministic concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as lists of locations,+    where the empty list is mapped to either `forbidden` or `underspecified`, depending on the transition label.+    Having multiple occurrences of a transition label is interpreted as non-deterministic choice between the destinations.+-}+nonDetConcTransFromListRel :: (Completable t, Ord loc, Ord t) => [(loc, t, [loc])] -> (loc -> Map t (NonDet ((), loc)))+nonDetConcTransFromListRel = fromJust <$> transFromRelWith (\x y -> Just (x \/ y)) vacuousTrans listToNonDet+    where+    listToNonDet list@(_:_) () _ = vacuousLoc <#> NonDet (Set.fromList list)+    listToNonDet [] () t = implicitDestination t++transFromRelWith :: (Ord loc, Ord t) =>+    (m (tdest, loc) -> m (tdest, loc) -> Maybe (m (tdest, loc))) -- the way of combining the monadic transitions resulting from two list elements, or Nothing if they cannot be combined+    -> (te -> (loc, t, tdest, loc')) -- the way of creating a 4-tuple with all the transition info from a list element+    -> (loc' -> tdest -> t -> m (tdest, loc)) -- the way of creating a monadic transition result from the transition info of a list element+    -> [te] -- the transition relation in a list representation+    -> Maybe (loc -> Map t (m (tdest, loc))) -- a transition function, or Nothing if combining two monadic transitions failed+transFromRelWith c' fe' f' trans = do+    tMapMap <- foldr (addToMap c' fe' f') (Just Map.empty) trans -- map from locations to a map from transitions to Dets+    Just $ \loc -> fromMaybe Map.empty $ loc `Map.lookup` tMapMap+    where+    addToMap :: (Ord loc, Ord t) => (m (tdest, loc) -> m (tdest, loc) -> Maybe (m (tdest, loc))) -> (te -> (loc, t, tdest, loc')) -> (loc' -> tdest -> t -> m (tdest, loc)) -> te -> Maybe (Map loc (Map t (m (tdest, loc)))) -> Maybe (Map loc (Map t (m (tdest, loc))))+    addToMap c fe f te maybeTMapMap = do+        tMapMap <- maybeTMapMap+        let (loc, t, tdest, loc') = fe te+        case loc `Map.lookup` tMapMap of+            Just tMap -> case t `Map.lookup` tMap of+                Nothing -> Just $ Map.insert loc (Map.insert t (f loc' tdest t) tMap) tMapMap+                Just prevLoc -> do+                    combinedLoc <- c prevLoc $ f loc' tdest t+                    Just $ Map.insert loc (Map.insert t combinedLoc tMap) tMapMap+            Nothing -> Just $ Map.insert loc (Map.singleton t (f loc' tdest t)) tMapMap++vacuousTrans :: (a, b, d) -> (a, b, (), d)+vacuousTrans (a,b,c) = (a,b,(),c)++vacuousLoc :: b -> ((), b)+vacuousLoc l = ((), l)+
+ src/Lattest/Model/StandardAutomata.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++{- |+    This module contains some simple automata types, and auxiliary functions for constructing them in a convenient manner.+    Note that the types are no more than type aliases, so if the automata type with your favorite combination of type parameters+    is not listed, don't hesitate to construct an automaton type ('AutSyntax' or 'AutIntrpr') yourself instead of using the StandardAutomata.+    The base function `automaton` for constructing automata is re-exported here for convenience.+-}++module Lattest.Model.StandardAutomata (+-- * Automaton construction+automaton,+-- * Alphabets+-- | Auxiliary functions useful for constructing alphabets, intended for creating automata via `automaton`.+ioAlphabet,+-- * Transition relations+-- | Auxiliary functions useful for constructing transition relations, intended for creating automata via `automaton`.++-- ** Deterministic Transition Relations+detConcTransFromRel,+detConcTransFromMRel,+detConcTransFromMaybeRel,+-- ** Non-Deterministic Transition Relations+nonDetConcTransFromRel,+nonDetConcTransFromMRel,+-- *** Alternating state configurations+-- | Re-exports, so that test scripts don't need to import BoundedMonad separately+FreeLattice,+atom,+top,+bot,+(\/),+(/\),+-- ** Transition Functions+transFromFunc,+concTransFromFunc,++-- * Automaton Semantics+-- | Auxiliary functions for creating semantical automata `AutIntrpr`. Note that most of these functions are no more than calls to `interpret`, instantiating+-- the type of the semantical interpretation.+ConcreteAutIntrpr,+interpretConcrete,+ConcreteSuspAutIntrpr,+interpretQuiescentConcrete,+ConcreteSuspInputAttemptAutIntrpr,+interpretInputAttemptConcrete,+interpretQuiescentInputAttemptConcrete,+STS,+IOSTS,+STSIntrp,+IOSTSIntrp,+accessSequences,+interpretSTS,+SuspSTSIntrp,+interpretSTSQuiescent,+SuspInputAttemptSTSIntrp,+interpretSTSQuiescentInputAttemptConcrete,+)+where++import Lattest.Model.Alphabet (IOAct(..), IOSuspAct, IFAct, SuspendedIF, SymInteract, IOSymInteract, GateValue, SuspendedIFGateValue, IOSuspGateValue)+import Lattest.Model.Automaton (AutSyntax, automaton, AutIntrpr, interpret, Completable, implicitDestination,IntrpState(..),STStdest, Valuation, transRel,syntacticAutomaton)+import Lattest.Model.BoundedMonad (Det(..), BoundedMonad, FreeLattice, atom, top, bot, (\/), (/\), JoinSemiLattice)+import qualified Lattest.Model.BoundedMonad as BM+import Lattest.Util.Utils(takeArbitrary)++import Data.Foldable (toList)++import qualified Data.Foldable as Foldable+import Data.Map (Map)+import qualified Data.Map as Map+import  Data.Maybe as Maybe+import qualified Data.Set as Set++-- | construct an alphabet of input-output-actions (`IOAct`) from separate alphabets of inputs and outputs+ioAlphabet :: (Traversable t, Ord i, Ord o) => t i -> t o -> Set.Set (IOAct i o)+ioAlphabet ti to = Set.fromList $ (In <$> toList ti) ++ (Out <$> toList to)++{- |+    Create a deterministic concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as explicit states.+    Having multiple occurrences of a transition label is forbidden, i.e., leads to a Nothing result.+-}+detConcTransFromRel :: (Ord loc, Ord t) => [(loc, t, loc)] -> Maybe (loc -> Map t (Det ((), loc)))+detConcTransFromRel = transFromRelWith combineDet vacuousTrans (\l () _ -> Det $ vacuousLoc l)++{- |+    Create a deterministic concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as deterministic state+    configuration. Having multiple occurrences of a transition label is forbidden, i.e., leads to a Nothing result.+-}+detConcTransFromMRel :: (Ord loc, Ord t) => [(loc, t, Det loc)] -> Maybe (loc -> Map t (Det ((), loc)))+detConcTransFromMRel = transFromRelWith combineDet vacuousTrans (\dl () _ -> fmap vacuousLoc dl)++{- |+    Create a deterministic concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as Just deterministic+    states, where `Nothing` is mapped to either `forbidden` or `underspecified`, depending on the transition label. Having multiple occurrences of a transition label is forbidden,+    i.e., leads to a Nothing result.+-}+detConcTransFromMaybeRel :: (Completable t, Ord loc, Ord t) => [(loc, t, Maybe loc)] -> Maybe (loc -> Map t (Det ((), loc)))+detConcTransFromMaybeRel = transFromRelWith combineDet vacuousTrans $ \mLoc () t -> case mLoc of+    Just loc -> vacuousLoc <$> Det loc+    Nothing -> implicitDestination t++{- |+    Create a non-deterministic concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as explicit states.+    The state configuration must support non-determinism, and having multiple occurrences of a transition label is interpreted as non-deterministic choice+    between the destinations.+-}+nonDetConcTransFromRel :: (Ord loc, Ord t, BM.OrdMonad m, JoinSemiLattice (m ((), loc))) => [(loc, t, loc)] -> (loc -> Map t (m ((), loc)))+nonDetConcTransFromRel = fromJust <$> transFromRelWith combineNonDet vacuousTrans (\l () _ -> BM.ordReturn $ vacuousLoc l)++{- |+    Create a non-deterministic symbolic transition relation from an explicit list of tuples, with the destination of transitions expressed as explicit states.+    The state configuration must support non-determinism, and having multiple occurrences of a transition label is interpreted as non-deterministic choice+    between the destinations.+-}+--nonDetSymbTransFromRel :: (Completable t, Ord loc, Ord t, Applicative m, JoinSemiLattice (m ((), loc))) => [(loc, t, tdest, loc)] -> (loc -> Map t (m (tdest, loc)))+--nonDetSymbTransFromRel = fromJust <$> transFromRelWith combineNonDet id (\l () _ -> pure $ vacuousLoc l)++{- |+    Create a concrete transition relation from an explicit list of tuples, with the destination of transitions expressed as non-deterministic state+    configuration. The state configuration must support non-determinism, and having multiple occurrences of a transition label is interpreted+    as non-deterministic choice between the destinations.+-}+nonDetConcTransFromMRel :: (Ord loc, Ord t, BM.OrdMonad m, JoinSemiLattice (m ((), loc))) => [(loc, t, m loc)] -> (loc -> Map t (m ((), loc)))+nonDetConcTransFromMRel = fromJust <$> transFromRelWith combineNonDet vacuousTrans (\ndl () _ -> BM.ordMap vacuousLoc ndl)++combineNonDet :: JoinSemiLattice a => a -> a -> Maybe a+combineNonDet x y = Just $ x \/ y++combineDet :: p1 -> p2 -> Maybe a+combineDet _ _ = Nothing++vacuousTrans :: (a, b, d) -> (a, b, (), d)+vacuousTrans (a,b,c) = (a,b,(),c)++vacuousLoc :: b -> ((), b)+vacuousLoc l = ((), l)++transFromRelWith :: (Ord loc, Ord t) =>+    (m (tdest, loc) -> m (tdest, loc) -> Maybe (m (tdest, loc))) -- the way of combining the monadic transitions resulting from two list elements, or Nothing if they cannot be combined+    -> (te -> (loc, t, tdest, loc')) -- the way of creating a 4-tuple with all the transition info from a list element+    -> (loc' -> tdest -> t -> m (tdest, loc)) -- the way of creating a monadic transition result from the transition info of a list element+    -> [te] -- the transition relation in a list representation+    -> Maybe (loc -> Map t (m (tdest, loc))) -- a transition function, or Nothing if combining two monadic transitions failed+transFromRelWith c' fe' f' trans = do+    tMapMap <- foldr (addToMap c' fe' f') (Just Map.empty) trans -- map from locations to a map from transitions to Dets+    Just $ \loc -> fromMaybe Map.empty $ loc `Map.lookup` tMapMap+    where+    addToMap :: (Ord loc, Ord t) => (m (tdest, loc) -> m (tdest, loc) -> Maybe (m (tdest, loc))) -> (te -> (loc, t, tdest, loc')) -> (loc' -> tdest -> t -> m (tdest, loc)) -> te -> Maybe (Map loc (Map t (m (tdest, loc)))) -> Maybe (Map loc (Map t (m (tdest, loc))))+    addToMap c fe f te maybeTMapMap = do+        tMapMap <- maybeTMapMap+        let (loc, t, tdest, loc') = fe te+        case loc `Map.lookup` tMapMap of+            Just tMap -> case t `Map.lookup` tMap of+                Nothing -> Just $ Map.insert loc (Map.insert t (f loc' tdest t) tMap) tMapMap+                Just prevLoc -> do+                    combinedLoc <- c prevLoc $ f loc' tdest t+                    Just $ Map.insert loc (Map.insert t combinedLoc tMap) tMapMap+            Nothing -> Just $ Map.insert loc (Map.singleton t (f loc' tdest t)) tMapMap++{- |+    Create a transition relation from a transition function. Warning: to use the resulting transition relation in an automaton, the function must be defined+    for all reachable states, and for all transition labels in the alphabet of the automaton.+-}+transFromFunc :: (Foldable fld, Ord t) => (loc -> t -> m (tdest, loc)) -> fld t -> (loc -> Map t (m (tdest, loc)))+transFromFunc fTrans alph loc = Map.fromSet (fTrans loc) (foldableAsSet alph)++{- |+    Create a concrete transition relation from a transition function. Warning: to use the resulting transition relation in an automaton, the function must be defined+    for all reachable states, and for all transition labels in the alphabet of the automaton.+-}+concTransFromFunc :: (Foldable fld, Functor m, Ord t) => (loc -> t -> m loc) -> fld t -> (loc -> Map t (m ((), loc)))+concTransFromFunc fTrans alph loc = Map.fromSet fTransConc (foldableAsSet alph)+    where+    fTransConc t = ((),) <$> fTrans loc t++foldableAsSet :: (Foldable fld, Ord a) => fld a -> Set.Set a+foldableAsSet fld = Set.fromList $ Foldable.toList fld++accessSequences :: (Ord loc, Foldable m) => AutIntrpr m loc loc t tdest act -> loc -> Map loc [t]+accessSequences aut initLoc =+    let initialMap = Map.singleton initLoc []+    in fst $ accessSequences' (syntacticAutomaton aut) initialMap $ Set.singleton initLoc++accessSequences' :: (Ord loc, Foldable m) => AutSyntax m loc t tdest -> Map loc [t] -> Set.Set loc -> (Map loc [t], Set.Set loc)+accessSequences' aut accMap boundary = case takeArbitrary boundary of+    Nothing -> (accMap, Set.empty)+    Just (q, boundaryRem) ->+        let ts = transRel aut q+            labelqs = concatMap (\(l,qs) -> zip (replicate (length qs) l) qs) $ Map.toList $ Map.map getStates ts+            (accMap',new) = foldr (\(label,dq) (m,new') -> insertLabelAndDestLocInAccMap q label dq m new') (accMap,Set.empty) labelqs+        in accessSequences' aut accMap' (boundaryRem `Set.union` new)+        where+        getStates = fmap snd . Foldable.toList++insertLabelAndDestLocInAccMap :: (Ord loc) => loc -> t -> loc -> Map loc [t] -> Set.Set loc -> (Map loc [t], Set.Set loc)+insertLabelAndDestLocInAccMap q label dq accMap new = case Map.lookup q accMap of+    Nothing -> error "could not lookup known location for access sequence"+    Just accSeq -> case addStateAndAccSeq accMap dq (accSeq ++ [label]) of+        (newMap,Nothing) -> (newMap, new)+        (newMap, Just q') -> (newMap, Set.insert q' new)++addStateAndAccSeq :: (Ord loc) => Map loc [t] -> loc -> [t] -> (Map loc [t], Maybe loc)+addStateAndAccSeq accMap q accSeq = case Map.lookup q accMap of+        Nothing -> (Map.insert q accSeq accMap, Just q)+        Just _ -> (accMap, Nothing)++---------------------------------+-- instantiations of interpret --+---------------------------------++-- | Semantics of automata in which syntactical states and actions are directly interpreted as literal, semantical states and actions.+type ConcreteAutIntrpr m q act = AutIntrpr m q q act () act++-- | Interpret syntactical states and actions directly as literal, semantical states and actions.+interpretConcrete :: (BoundedMonad m, Ord t, Ord loc, Completable t) => AutSyntax m loc t () -> ConcreteAutIntrpr m loc t+interpretConcrete = flip interpret id++-- | Semantics of automata in which syntactical states and actions are directly interpreted as literal, semantical states and actions, but with timeouts as possible output observations.+type ConcreteSuspAutIntrpr m q i o = AutIntrpr m q q (IOAct i o) () (IOSuspAct i o)++-- | Interpret syntactical states and actions are directly as literal, semantical states and actions, but with timeouts as possible output observations.+interpretQuiescentConcrete :: (BoundedMonad m, Ord i, Ord o, Ord loc) => AutSyntax m loc (IOAct i o) () -> ConcreteSuspAutIntrpr m loc i o+interpretQuiescentConcrete = flip interpret id++-- | Semantics of automata in which syntactical states and actions are directly interpreted as literal, semantical states and actions, but with input failures as possible input observations.+type ConcreteInputAttemptAutIntrpr m q i o = AutIntrpr m q q (IOAct i o) () (IFAct i o)++-- | Interpret syntactical states and actions are directly as literal, semantical states and actions, but with input failures as possible input observations.+interpretInputAttemptConcrete :: (BoundedMonad m, Ord i, Ord o, Ord loc) => AutSyntax m loc (IOAct i o) () -> ConcreteInputAttemptAutIntrpr m loc i o+interpretInputAttemptConcrete = flip interpret id++-- | Semantics of automata in which syntactical states and actions are directly interpreted as literal, semantical states and actions, but with timeouts and input failures as possible observations.+type ConcreteSuspInputAttemptAutIntrpr m q i o = AutIntrpr m q q (IOAct i o) () (SuspendedIF i o)++-- | Interpret syntactical states and actions are directly as literal, semantical states and actions, but with timeouts and input failures as possible observations.+interpretQuiescentInputAttemptConcrete :: (BoundedMonad m, Ord i, Ord o, Ord loc) => AutSyntax m loc (IOAct i o) () -> ConcreteSuspInputAttemptAutIntrpr m loc i o+interpretQuiescentInputAttemptConcrete = flip interpret id++type STS m loc g = AutSyntax m loc (SymInteract g) STStdest+type IOSTS m loc i o = STS m loc (IOAct i o)++type STSIntrp m loc g = AutIntrpr m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g)+type IOSTSIntrp m loc i o = STSIntrp m loc (IOAct i o)++interpretSTS :: (Ord loc, BoundedMonad m, Completable (GateValue g)) => STS m loc g -> Valuation -> STSIntrp m loc g+interpretSTS sts initialValuation = interpret sts (`IntrpState` initialValuation)++type SuspSTSIntrp m loc i o = AutIntrpr m loc (IntrpState loc) (IOSymInteract i o) STStdest (IOSuspGateValue i o)++interpretSTSQuiescent :: (Ord loc, BoundedMonad m) => IOSTS m loc i o -> Valuation -> SuspSTSIntrp m loc i o+interpretSTSQuiescent sts initialValuation = interpret sts (`IntrpState` initialValuation)++-- TODO also list an interpretation for quiescence only and input-failure only+type SuspInputAttemptSTSIntrp m loc i o = AutIntrpr m loc (IntrpState loc) (IOSymInteract i o) STStdest (SuspendedIFGateValue i o)++interpretSTSQuiescentInputAttemptConcrete  :: (Ord loc, BoundedMonad m) => IOSTS m loc i o -> Valuation -> SuspInputAttemptSTSIntrp m loc i o+interpretSTSQuiescentInputAttemptConcrete sts initialValuation = interpret sts (`IntrpState` initialValuation)+
+ src/Lattest/Model/Symbolic/Expr.hs view
@@ -0,0 +1,26 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+module Lattest.Model.Symbolic.Expr+( Expr+, view+, ExprView(..)+, Type(..)+, Constant(..)+, constType+, ConstType+, fromConst+, toConst+, Variable(..)+, eval+, freeVars+, module Lattest.Model.Symbolic.Internal.ExprImpls+, module Lattest.Model.Symbolic.Internal.ExprImplsExtension+)+where++import           Lattest.Model.Symbolic.Internal.ExprDefs+import           Lattest.Model.Symbolic.Internal.ExprImpls+import           Lattest.Model.Symbolic.Internal.ExprImplsExtension
+ src/Lattest/Model/Symbolic/Internal/Boute.hs view
@@ -0,0 +1,57 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+-- Define div and mod according to Boute's Euclidean definition, that is,+--  so as to satisfy the formula+--+-- @+--  (for all ((m Int) (n Int))+--    (=> (distinct n 0)+--        (let ((q (div m n)) (r (mod m n)))+--          (and (= m (+ (* n q) r))+--               (<= 0 r (- (abs n) 1))))))+-- @+--+-- Boute, Raymond T. (April 1992). +--      The Euclidean definition of the functions div and mod. +--      ACM Transactions on Programming Languages and Systems (TOPLAS) +--      ACM Press. 14 (2): 127 - 144. doi:10.1145/128861.128862.+-----------------------------------------------------------------------------+module Lattest.Model.Symbolic.Internal.Boute+( Lattest.Model.Symbolic.Internal.Boute.divMod+, Lattest.Model.Symbolic.Internal.Boute.div+, Lattest.Model.Symbolic.Internal.Boute.mod+)+where+-- | operator divMod on the provided integer values.+-- +-- @+--  (for all ((m Int) (n Int))+--    (=> (distinct n 0)+--        (let ((q (div m n)) (r (mod m n)))+--          (and (= m (+ (* n q) r))+--               (<= 0 r (- (abs n) 1))))))+-- @+divMod :: Integer -> Integer -> (Integer, Integer)+divMod _ 0 = error "divMod: division by zero"+divMod m n = if n > 0 || pm == 0+                then pdm+                else (pd+1, pm-n)+    where pdm@(pd, pm) = Prelude.divMod m n++-- | operator divide on the provided integer values.+div :: Integer -> Integer -> Integer+div m = fst . Lattest.Model.Symbolic.Internal.Boute.divMod m++-- | operator modulo on the provided integer values.+-- +-- @+--  (for all ((m Int) (n Int)) +--    (=> (distinct n 0)+--               (<= 0 (mod m n) (- (abs n) 1))))+-- @+mod :: Integer -> Integer -> Integer+mod m = snd . Lattest.Model.Symbolic.Internal.Boute.divMod m+
+ src/Lattest/Model/Symbolic/Internal/ExprDefs.hs view
@@ -0,0 +1,368 @@+{-# OPTIONS_HADDOCK hide, prune #-}+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Lattest.Model.Symbolic.Internal.ExprDefs+( ExprView(..)+, Expr(..)       -- for local usage only!+, eval+, reduce+, Variable(..)+, Type(..)+, allTypes+, Constant(..)+, constType+, ConstType+, fromConst+, toConst+, ExprType+, typeOf+, typeOf'+, isConst+, freeVars+)+where++import qualified Data.List as List+import           Data.Set         (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text(pack, unpack)+import           GHC.Integer (divInteger)++import           Lattest.Model.Symbolic.Internal.FreeMonoidX+import qualified Lattest.Model.Symbolic.Internal.FreeMonoidX as FMX+import           Lattest.Model.Symbolic.Internal.Product+import           Lattest.Model.Symbolic.Internal.Sum++import qualified Data.Aeson as JSON+import qualified Data.Aeson.KeyMap as JSON++import Data.Scientific (toRealFloat, fromFloatDigits, floatingOrInteger)++data Type = IntType | BoolType | StringType | FloatType deriving (Eq, Ord)++allTypes :: [Type]+allTypes = [IntType, BoolType, StringType, FloatType]++class ExprType t where+    typeOf :: t -> Type+    typeOf' :: f t -> Type++instance ExprType Integer where+    typeOf _ = IntType+    typeOf' _ = IntType+instance ExprType Bool where+    typeOf _ = BoolType+    typeOf' _ = BoolType+instance ExprType String where+    typeOf _ = StringType+    typeOf' _ = StringType+instance ExprType Double where+    typeOf _ = FloatType+    typeOf' _ = FloatType++instance Show Type where+    show IntType = "Int"+    show BoolType = "Bool"+    show StringType = "String"+    show FloatType = "Float"++data Variable = Variable {varName :: String, varType :: Type} deriving (Eq, Ord)++instance Show Variable where+    show (Variable name stype) = name ++ ":" ++ show stype++data Constant = -- | Constructor of Boolean constant.+                Cbool    { toBool :: Bool }+                -- | Constructor of Integer constant.+              | Cint     { toInteger :: Integer }+                -- | Constructor of String constant.+              | Cstring  { toString :: String }+                -- | Constructor of floating-point constant.+              | Cfloat   { toFloat :: Double }+                -- | Constructor of constructor constant (value of ADT).+              | Ccstr    { cstrName :: String, args :: [Constant] }+{-+                -- | Constructor of Regular Expression constant.+              | Cregex   { -- | Regular Expression in XSD format+                           toXSDRegex :: Text } +                                            -- PvdL: performance gain: translate only once,+                                            --       storing SMT string as well+                -- | Constructor of ANY constant.+              | Cany     { sort :: SortId }+-}+  deriving (Eq, Ord, Read)+instance JSON.FromJSON Constant where+    parseJSON (JSON.Object m)+        | not $ JSON.member "value" m = fail "expected Constant with a value field"+        | not $ JSON.member "type" m = fail "expected Constant with a type field"+    parseJSON (JSON.Object m)+        | JSON.lookup "type" m == Just "bool" = parseBool $ lkup "value" m+        | JSON.lookup "type" m == Just "int" = parseInt $ lkup "value" m+        | JSON.lookup "type" m == Just "string" = parseString $ lkup "value" m+        | JSON.lookup "type" m == Just "float" = parseFloat $ lkup "value" m+        where+        lkup :: JSON.Key -> JSON.KeyMap v -> v+        lkup k = Maybe.fromJust . JSON.lookup k+        parseBool (JSON.Bool b) = return $ Cbool b+        parseBool _ = fail "type indicates bool, but value is not of type bool"+        parseInt (JSON.Number (floatingOrInteger @Double -> Right i)) = return $ Cint i+        parseInt _ = fail "type indicates int, but value is not of type int"+        parseString (JSON.String s) = return $ Cstring $ Text.unpack s+        parseString _ = fail "type indicates string, but value is not of type string"+        parseFloat (JSON.Number n) = return $ Cfloat $ toRealFloat n+        parseFloat _ = fail "type indicates float, but value is not of type float"+    parseJSON _ = fail "expected Constant JSON"++instance JSON.ToJSON Constant where+    toJSON (Cbool b) = JSON.Object $ JSON.insert "type" "bool" $ JSON.insert "value" (JSON.Bool b) JSON.empty+    toJSON (Cint i) = JSON.Object $ JSON.insert "type" "int" $ JSON.insert "value" (JSON.Number $ fromInteger i) JSON.empty+    toJSON (Cstring s) = JSON.Object $ JSON.insert "type" "string" $ JSON.insert "value" (JSON.String $ Text.pack s) JSON.empty+    toJSON (Cfloat f) = JSON.Object $ JSON.insert "type" "float" $ JSON.insert "value" (JSON.Number $ fromFloatDigits f) JSON.empty+    toJSON (Ccstr _ _) = error "toJSON cstr"++constType :: Constant -> Type+constType (Cbool _) = BoolType+constType (Cint _) = IntType+constType (Cstring _) = StringType+constType (Cfloat _) = FloatType+constType (Ccstr _ _) = error "type cstr"++instance Show Constant where+  show (Cbool b) = show b+  show (Cint i) = show i+  show (Cstring t) = show t+  show (Cfloat f) = show f+  show (Ccstr a b) = show a <> " " <> show b++-- | convert a Constant to an typed value+class ConstType t where+    fromConst :: Constant -> Either String t+    toConst :: t -> Constant++instance ConstType Bool where+    fromConst (Cbool b) = Right b+    fromConst v = Left $ typeError "Bool" v+    toConst = Cbool++instance ConstType Integer where+    fromConst (Cint i) = Right i+    fromConst v = Left $ typeError "Int" v+    toConst = Cint++instance ConstType String where+    fromConst (Cstring s) = Right s+    fromConst v = Left $ typeError "String" v+    toConst = Cstring++instance ConstType Double where+    fromConst (Cfloat f) = Right f+    fromConst (Cint i) = Right (fromInteger i)+    fromConst v = Left $ typeError "Float" v+    toConst = Cfloat++typeError :: String -> Constant -> String+typeError received expected = "Type mismatch - " ++ show expected ++ " expected, got " ++ received ++ "\n"+++-- ----------------------------------------------------------------------------------------- --+-- value expression++data ExprView t where+    Var :: {variable :: Variable} -> ExprView t+    Const :: ExprType t => {constant :: t} -> ExprView t+    Ite :: {conditional :: ExprView Bool, trueBranch :: ExprView t, falseBranch :: ExprView t} -> ExprView t+    {-+    No polymorphic Equal possible, because that would make sensible Eq and Ord instances impossible: Equal 1 2 and Equal+    "a" "b" are both ExprView Bool's, but an == on those expressions would have to compare 1 == "a" and 2 == "b".+    Var, Const and Ite don't have this problem because the argument types are forced to be equal through the return type.+    -}+    EqualInt :: {leftInt :: ExprView Integer, rightInt :: ExprView Integer} -> ExprView Bool+    EqualString :: {leftString :: ExprView String, rightString :: ExprView String} -> ExprView Bool+    EqualBool :: {leftBool :: ExprView Bool, rightBool :: ExprView Bool} -> ExprView Bool+    EqualFloat :: {leftFloat :: ExprView Double, rightFloat :: ExprView Double} -> ExprView Bool+    Divide :: {dividend2 :: ExprView Integer, divisor2 :: ExprView Integer} -> ExprView Integer+    Modulo :: {dividend2 :: ExprView Integer, divisor2 :: ExprView Integer} -> ExprView Integer+    DivideFloat :: {dividendF :: ExprView Double, divisorF :: ExprView Double} -> ExprView Double+    Sum :: FreeSum (ExprView Integer) -> ExprView Integer+    SumFloat :: FreeSum (ExprView Double) -> ExprView Double+    Product :: FreeProduct (ExprView Integer) -> ExprView Integer+    ProductFloat :: FreeProduct (ExprView Double) -> ExprView Double+    Length :: ExprView String -> ExprView Integer+    GezInt :: ExprView Integer -> ExprView Bool+    GezFloat :: ExprView Double -> ExprView Bool+    Not :: ExprView Bool -> ExprView Bool+    And :: Set (ExprView Bool) -> ExprView Bool+    Concat :: [ExprView String] -> ExprView String++deriving instance Eq t => Eq (ExprView t)+deriving instance Ord t => Ord (ExprView t)++instance Show t => Show (ExprView t) where+    show (Var v) = varName v+    show (Const c) = show c+    show (Ite cond e1 e2) = "if (" ++ show cond ++ ") then (" ++ show e1 ++ ") else (" ++ show e2 ++ ")"+    show (Divide e1 e2) = "(" ++ show e1 ++ ") / (" ++ show e2 ++ ")"+    show (Modulo e1 e2) = "(" ++ show e1 ++ ") % (" ++ show e2 ++ ")"+    show (DivideFloat e1 e2) = "(" ++ show e1 ++ ") / (" ++ show e2 ++ ")"+    show (Sum es) | es == mempty = "∑∅"+    show (Sum es) = "(" ++ showFreeMonoid "+" showSumTerm es ++ ")"+        where+        showSumTerm (-1)     t = "-" ++ t+        showSumTerm 1 t = t+        showSumTerm n t = show n ++ "⋅" ++ t+    show (Product es) | es == mempty = "∏∅"+    show (Product es) = showFreeMonoid "⋅" (\n t -> show n ++ "^" ++ t) es -- "(" ++ show e2 ++ ")" --FreeProduct Expr+    show (SumFloat es) | es == mempty = "∑∅"+    show (SumFloat es) = "(" ++ showFreeMonoid "+" showSumTerm es ++ ")"+        where+        showSumTerm (-1)     t = "-" ++ t+        showSumTerm 1 t = t+        showSumTerm n t = show n ++ "⋅" ++ t+    show (ProductFloat es) | es == mempty = "∏∅"+    show (ProductFloat es) = showFreeMonoid "⋅" (\n t -> show n ++ "^" ++ t) es+    show (Length e) = "length(" ++ show e ++ ")"+    show (EqualInt e1 e2) = "(" ++ show e1 ++ ") = (" ++ show e2 ++ ")"+    show (EqualBool e1 e2) = "(" ++ show e1 ++ ") = (" ++ show e2 ++ ")"+    show (EqualString e1 e2) = "(" ++ show e1 ++ ") = (" ++ show e2 ++ ")"+    show (EqualFloat e1 e2) = "(" ++ show e1 ++ ") = (" ++ show e2 ++ ")"+    show (GezInt e) = "(" ++ show e ++ ") ≥ 0"+    show (GezFloat e) = "(" ++ show e ++ ") ≥ 0"+    show (Not e) = "¬(" ++ show e ++ ")"+    show (And (Set.toList -> [])) = "⋀∅"+    show (And (Set.toList -> es)) = List.intercalate "∧" $ (\e -> "(" ++ show e ++ ")") <$>  es+    show (Concat []) = "∑'∅"+    show (Concat es) = List.intercalate "++" $ (\e -> "(" ++ show e ++ ")") <$> es++showFreeMonoid :: Show a => String -> (Integer -> String -> String) -> FreeMonoidX a -> String+showFreeMonoid plusRepr multRepr (FMX p) = List.intercalate plusRepr $ showTerm <$> Map.assocs p+    where+    showTerm (x, i) = multRepr i (show x)+++-- | Expr: value expression+-- 1. User can't directly construct Expr (such that invariants will always hold)+-- 2. User can still pattern match on Expr using 'ExprView'+-- 3. Overhead at run-time is zero. See https://wiki.haskell.org/Performance/Data_types#Newtypes+newtype Expr t = Expr {view :: ExprView t} deriving (Eq, Ord)++instance Show t => Show (Expr t) where+    show = show . view++-- | Evaluate the provided value expression.+-- Either the Right Constant Value is returned or a (Left) error message.+eval :: Expr v -> Either String v+eval = evalView . view++evalView :: ExprView v -> Either String v+evalView (reduce -> Const v) = Right v+evalView _ = Left "Value Expression is not a constant value"++isConst :: ExprView v -> Bool+isConst (Const _) = True+isConst _ = False++reduce :: ExprView v -> ExprView v+--reduce (view -> Vfunc (FuncId _nm _uid _fa fs) _vexps)         =+--reduce (view -> Vcstr (CstrId _nm _uid _ca cs) _vexps)         =+--reduce (view -> Viscstr { })                                   =+--reduce (view -> Vaccess (CstrId _nm _uid ca _cs) _n p _vexps)  =+reduce (Var v) = Var v+reduce (Const v) = Const v+reduce (Ite (reduce -> Const b) (reduce -> e1) (reduce -> e2)) = if b then e1 else e2+reduce (Ite (reduce -> c) (reduce -> e1) (reduce -> e2)) = Ite c e1 e2+reduce (Sum (mapFreeMonoidX reduce -> es)) | allFreeMonoidX isConst es = Const $ FMX.fold $ mapFreeMonoidX constant es+reduce (Sum (mapFreeMonoidX reduce -> es)) = Sum es+reduce (SumFloat (mapFreeMonoidX reduce -> es)) | allFreeMonoidX isConst es = Const $ FMX.fold $ mapFreeMonoidX constant es+reduce (SumFloat (mapFreeMonoidX reduce -> es)) = SumFloat es+reduce (Product (mapFreeMonoidX reduce -> es)) | allFreeMonoidX isConst es = Const $ FMX.fold $ mapFreeMonoidX constant es+reduce (Product (mapFreeMonoidX reduce -> es)) = Product es+reduce (ProductFloat (mapFreeMonoidX reduce -> es)) | allFreeMonoidX isConst es = Const $ FMX.fold $ mapFreeMonoidX constant es+reduce (ProductFloat (mapFreeMonoidX reduce -> es)) = ProductFloat es+reduce (Modulo (reduce -> e1) (reduce -> e2@(Const 0))) = Modulo e1 e2 -- leave divisions by zero as expressions+reduce (Modulo (reduce -> (Const x)) (reduce -> (Const y))) = Const $ x `mod` y+reduce (Modulo (reduce -> e1) (reduce -> e2)) = Modulo e1 e2+reduce (Divide (reduce -> e1) (reduce -> e2@(Const 0))) = Divide e1 e2 -- leave divisions by zero as expressions+reduce (Divide (reduce -> (Const x)) (reduce -> (Const y))) = Const $ x `divInteger` y+reduce (Divide (reduce -> e1) (reduce -> e2)) = Divide e1 e2+reduce (DivideFloat (reduce -> e1) (reduce -> e2@(Const 0))) = DivideFloat e1 e2 -- leave divisions by zero as expressions+reduce (DivideFloat (reduce -> (Const x)) (reduce -> (Const y))) = Const $ x / y+reduce (DivideFloat (reduce -> e1) (reduce -> e2)) = DivideFloat e1 e2+reduce (Length (reduce -> (Const s))) = Const $ fromIntegral $ length s+reduce (Length (reduce -> e)) = Length e+--reduce (view -> Vstrinre { })                                  =+--reduce (view -> Vpredef _kd (FuncId _nm _uid _fa fs) _vexps)   =++--reduce (view -> Vfunc (FuncId _nm _uid _fa fs) _vexps)         =+--reduce (view -> Vcstr (CstrId _nm _uid _ca cs) _vexps)         =+--reduce (view -> Viscstr { })                                   =+--reduce (view -> Vaccess (CstrId _nm _uid ca _cs) _n p _vexps)  =+reduce (EqualInt (reduce -> Const e1) (reduce -> Const e2)) = Const (e1 == e2)+reduce (EqualInt (reduce -> e1) (reduce -> e2)) = EqualInt e1 e2+reduce (EqualBool (reduce -> Const e1) (reduce -> Const e2)) = Const (e1 == e2)+reduce (EqualBool (reduce -> e1) (reduce -> e2)) = EqualBool e1 e2+reduce (EqualString (reduce -> Const e1) (reduce -> Const e2)) = Const (e1 == e2)+reduce (EqualString (reduce -> e1) (reduce -> e2)) = EqualString e1 e2+reduce (EqualFloat (reduce -> Const e1) (reduce -> Const e2)) = Const (e1 == e2)+reduce (EqualFloat (reduce -> e1) (reduce -> e2)) = EqualFloat e1 e2+reduce (GezInt (reduce -> (Const x))) = Const $ x >= 0+reduce (GezInt (reduce -> e)) = GezInt e+reduce (GezFloat (reduce -> (Const x))) = Const $ x >= 0+reduce (GezFloat (reduce -> e)) = GezFloat e+reduce (Not (reduce -> (Const b))) = Const $ not b+reduce (Not (reduce -> e)) = Not e+reduce (And (Set.map reduce -> es)) | all isConst es = Const $ and (Set.map constant es) -- TODO could be optimized further: if not all elements are constant, but if there are multiple constant elements, then the latter could still be combined+reduce (And (Set.map reduce -> es)) = And es+--reduce (view -> Vstrinre { })                                  =+--reduce (view -> Vpredef _kd (FuncId _nm _uid _fa fs) _vexps)   =++--reduce (view -> Vfunc (FuncId _nm _uid _fa fs) _vexps)         =+--reduce (view -> Vcstr (CstrId _nm _uid _ca cs) _vexps)         =+--reduce (view -> Viscstr { })                                   =+--reduce (view -> Vaccess (CstrId _nm _uid ca _cs) _n p _vexps)  =+reduce (Concat (fmap reduce -> es)) | all isConst es = Const $ concatMap constant es -- TODO could be optimized further: if not all elements are constant, but if there are multiple successive constant elements, then the latter could still be combined+reduce (Concat (fmap reduce -> e)) = Concat e+--reduce (view -> Vstrinre { })                                  =+--reduce (view -> Vpredef _kd (FuncId _nm _uid _fa fs) _vexps)   =++-- ----------------------------------------------------------------------------------------- --+--+-- ----------------------------------------------------------------------------------------- --++freeVars :: Expr t -> Set.Set Variable+freeVars = Set.fromList . freeVars' . view++freeVars' :: ExprView t -> [Variable]+freeVars' (Var v) = [v]+freeVars' (Const _) = []+freeVars' (Ite cond e1 e2) = freeVars' cond ++ freeVars' e1 ++ freeVars' e2+freeVars' (Divide e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (Modulo e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (DivideFloat e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (Sum (distinctTermsT -> es)) = concatMap freeVars' es+freeVars' (SumFloat (distinctTermsT -> es)) = concatMap freeVars' es+freeVars' (Product (distinctTermsT -> es)) = concatMap freeVars' es+freeVars' (ProductFloat (distinctTermsT -> es)) = concatMap freeVars' es+freeVars' (Length e) = freeVars' e+freeVars' (EqualInt e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (EqualBool e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (EqualString e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (EqualFloat e1 e2) = freeVars' e1 ++ freeVars' e2+freeVars' (GezInt e) = freeVars' e+freeVars' (GezFloat e) = freeVars' e+freeVars' (Not e) = freeVars' e+freeVars' (And (Set.toList -> es)) = concatMap freeVars' es+freeVars' (Concat es) = concatMap freeVars' es+
+ src/Lattest/Model/Symbolic/Internal/ExprImpls.hs view
@@ -0,0 +1,754 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE MonoLocalBinds      #-}+{-# LANGUAGE FlexibleInstances #-}+module Lattest.Model.Symbolic.Internal.ExprImpls+( -- * Constructors to create Value Expressions+  -- ** Constant value+  sConst+, sTrue+, sFalse+  -- ** VarRef+, sVar+  -- ** General Operators to create Value Expressions+  -- *** Equal+, (.==)+  -- *** If Then Else+, sIfThenElse+  -- *** Function Call+--, cstrFunc+  -- ** Boolean Operators to create Value Expressions+  -- *** Not+, sNot+  -- *** And+, sAnd+  -- ** Numeric Operators to create Value Expressions+, ExprNum+  -- *** Sum+, sSum+  -- *** Product+, sProduct+  -- *** Divide+, (./)+  -- *** Modulo+, (.%)+  -- *** Comparisons GEZ+, sIsNonNegative+  -- ** String Operators to create Value Expressions+  -- *** Length operator+, sLength+  -- *** Concat operator+, sConcat+  -- ** Regular Expression Operators to create Value Expressions+  -- *** String in Regular Expression operator+--, cstrStrInRe+  -- ** Algebraic Data Type Operators to create Value Expressions+  -- *** Algebraic Data Type constructor operator+--, cstrCstr+  -- *** Algebraic Data Type IsConstructor function+--, cstrIsCstr+  -- *** Algebraic Data Type Accessor+--, cstrAccess++-- to be documented+--, cstrPredef+-- * Substitution of var by value+, VarModel+, Assignable+, assign+, Valuation+, toConstantsMap+, fromConstantsMap+, emptyValuation+, assignValues+, assignValue+, insertIntoValuation+, substConst+, subst+, assignedExpr+, assignment+, noAssignment+, (=:)+)+where++import           Control.Arrow   (first)+import qualified Data.List       as List+import qualified Data.Map        as Map+import qualified Data.Set        as Set+--import           Text.Regex.TDFA++import qualified Lattest.Model.Symbolic.Internal.Boute as Boute+import qualified Lattest.Model.Symbolic.Internal.FreeMonoidX        as FMX+import           Lattest.Model.Symbolic.Internal.Product as Product+--import           Lattest.Model.Symbolic.Expr.RegexXSD2Posix+import           Lattest.Model.Symbolic.Internal.Sum as Sum+import           Lattest.Model.Symbolic.Internal.ExprDefs++-- | Create a function call.+-- Preconditions are /not/ checked.+{-cstrFunc :: (Variable v, Variable w) => Map.Map FuncId (FuncDef v) -> FuncId -> [Expr w] -> Expr w+cstrFunc fis fi arguments =+    case Map.lookup fi fis of+        Nothing ->+            -- When implementing the body of a recursive function, a function+            -- call is made while the implementation is not (yet) finished and+            -- available.+            Expr (Vfunc fi arguments)+        Just (FuncDef params body)->+            case view body of+                Vconst x -> cons x+                _        -> if all isConst arguments+                            then compSubst (Map.fromList (zip params arguments)) fis body+                            else Expr (Vfunc fi arguments)++-- | Apply ADT Constructor of constructor with CstrId and the provided arguments (the list of value expressions).+-- Preconditions are /not/ checked.+cstrCstr :: CstrId -> [Expr] -> Expr+cstrCstr c a = if all isConst a+                then cons (Ccstr c (map toConst a) )+                else Expr (Vcstr c a)+    where   toConst :: Expr -> Constant+            toConst (view -> Vconst v) = v+            toConst _                  = error "Impossible when all satisfy isConst"++-- | Is the provided value expression made by the ADT constructor with CstrId?+-- Preconditions are /not/ checked.+cstrIsCstr :: CstrId -> Expr -> Expr+cstrIsCstr c1 (view -> Vcstr c2 _)          = cons (Cbool (c1 == c2) )+cstrIsCstr c1 (view -> Vconst (Ccstr c2 _)) = cons (Cbool (c1 == c2) )+cstrIsCstr c e                              = Expr (Viscstr c e)++-- | Apply ADT Accessor of constructor with CstrId on field with given position on the provided value expression.+-- Preconditions are /not/ checked.+cstrAccess :: CstrId -> T.Text -> Int -> Expr -> Expr+cstrAccess c1 n1 p1 (view -> Vcstr c2 fields) =+    if c1 == c2 -- prevent crashes due to model errors+        then fields!!p1+        else error ("Error in model: Accessing field " ++ show n1 ++ " of constructor " ++ show c1 ++ " on instance from constructor " ++ show c2)+cstrAccess c1 n1 p1 (view -> Vconst (Ccstr c2 fields)) =+    if c1 == c2 -- prevent crashes due to model errors+        then cons (fields!!p1)+        else error ("Error in model: Accessing field " ++ show n1 ++ " of constructor " ++ show c1 ++ " on value from constructor " ++ show c2)+cstrAccess c n p e = Expr (Vaccess c n p e)+-}+-- | Is Expr a Constant/Value Expression?+--isConst :: Expr -> Bool+--isConst (view -> Vconst{}) = True+--isConst _                  = False++sConst :: ExprType t => t -> Expr t+sConst = Expr . Const++sTrue :: Expr Bool+sTrue = sConst True++sFalse :: Expr Bool+sFalse = sConst False++class VarExpr t where+    sVar :: Variable -> Expr t++instance VarExpr Integer where+    sVar v@(Variable _ IntType) = sVar' v+    sVar (Variable n t) = error $ "Variable expression for '" ++ n ++ "' of wrong type: expected Integer, received " ++ show t++instance VarExpr Bool where+    sVar v@(Variable _ BoolType) = sVar' v+    sVar (Variable n t) = error $ "Variable expression for '" ++ n ++ "' of wrong type: expected Bool, received " ++ show t++instance VarExpr String where+    sVar v@(Variable _ StringType) = sVar' v+    sVar (Variable n t) = error $ "Variable expression for '" ++ n ++ "' of wrong type: expected String, received " ++ show t++instance VarExpr Double where+    sVar v@(Variable _ FloatType) = sVar' v+    sVar (Variable n t) = error $ "Variable expression for '" ++ n ++ "' of wrong type: expected Real, received " ++ show t++sVar' :: Variable -> Expr t+sVar' = Expr . Var++-- | Apply operator ITE (IF THEN ELSE) on the provided value expressions.+-- Preconditions are /not/ checked.+sIfThenElse :: Expr Bool -> Expr t -> Expr t -> Expr t+sIfThenElse (view -> Const True) t _ = t+sIfThenElse (view -> Const False) _ f = f+sIfThenElse (view -> c) (view -> t) (view -> f) = Expr $ Ite c t f++-- | Create a variable as a value expression.+-- typeclass because every type has its own ExprView-constructor+class EqExpr t where+    (.==) :: Expr t -> Expr t -> Expr Bool++instance EqExpr Integer where+    (.==) (view -> x) (view -> y) = Expr $ EqualInt x y++instance EqExpr Bool where+    (.==) (view -> x) (view -> y) = Expr $ EqualBool x y++instance EqExpr String where+    (.==) (view -> x) (view -> y) = Expr $ EqualString x y++instance EqExpr Double where+    (.==) (view -> x) (view -> y) = Expr $ EqualFloat x y++infix 4 .==++{-+-- | Apply operator Equal on the provided value expressions.+-- Preconditions are /not/ checked.+(.==) :: Expr -> Expr -> Expr+-- Simplification a == a <==> True+(.==) ve1 ve2 | ve1 == ve2                      = sConst (Cbool True)+-- Simplification Different Values <==> False : use Same Values are already detected in previous step+(.==) (view -> Vconst _) (view -> Vconst _)     = sConst (Cbool False)+-- Simplification True == e <==> e (twice)+(.==) (view -> Vconst (Cbool True)) e           = e+(.==) e (view -> Vconst (Cbool True))           = e++-- Simplification False == e <==> not e (twice)+(.==) (view -> Vconst (Cbool False)) e              = sNot e+(.==) e (view -> Vconst (Cbool False))              = sNot e+-- Not x == x <==> false (twice)+(.==) e (view -> Vnot n) | e == n                   = sConst (Cbool False)+(.==) (view -> Vnot n) e | e == n                   = sConst (Cbool False)+-- Not x == Not y <==> x == y   -- same representation+(.==) (view -> Vnot n1) (view -> Vnot n2)     = (.==) n1 n2+-- Not a == b <==> a == Not b -- same representation (twice)+(.==) x@(view -> Vnot n) e                = if n <= e+                                                        then Expr (Vequal x e)+                                                        else Expr (Vequal (sNot e) n)+(.==) e x@(view -> Vnot n)                = if n <= e+                                                        then Expr (Vequal x e)+                                                        else Expr (Vequal (sNot e) n)+-- a == b <==> b == a -- same representation+(.==) ve1 ve2                                   = if ve1 <= ve2+                                                        then Expr (Vequal ve1 ve2)+                                                        else Expr (Vequal ve2 ve1)+-}++-- | Apply operator Not on the provided value expression.+-- Preconditions are /not/ checked.+sNot :: Expr Bool -> Expr Bool+{-sNot (view -> Vconst (Cbool True))       = sConst (Cbool False)+sNot (view -> Vconst (Cbool False))      = sConst (Cbool True)+sNot (view -> Vnot ve)                   = ve+-- not (if cs then tb else fb) == if cs then not (tb) else not (fb)+sNot (view -> Vite cs tb fb)             = Expr (Vite cs (sNot tb) (sNot fb))-}+sNot (view -> ve) = Expr $ Not ve++-- | Apply operator And on the provided set of value expressions.+-- Preconditions are /not/ checked.+sAnd :: Set.Set (Expr Bool) -> Expr Bool+--sAnd = sAnd' . flattenAnd+sAnd = Expr . And . flattenAnd+    where+        flattenAnd :: Set.Set (Expr Bool) -> Set.Set (ExprView Bool)+        flattenAnd = Set.unions . map fromExpr . Set.toList++        fromExpr :: Expr Bool -> Set.Set (ExprView Bool)+        fromExpr (view -> And a) = a+        fromExpr (view -> x) = Set.singleton x+{-+-- And doesn't contain elements of type Vand.+sAnd' :: Set.Set Expr Bool -> Expr Bool+sAnd' s =+    if Set.member (sConst (Cbool False)) s+        then sConst (Cbool False)+        else let s' = Set.delete (sConst (Cbool True)) s in+                case Set.size s' of+                    0   -> sConst (Cbool True)+                    1   -> head (Set.toList s')+                    _   ->  -- not(x) and x == False+                            let nots = filterNot (Set.toList s') in+                                if any (contains s') nots+                                    then sConst (Cbool False)+--                                    else let ts = isCstrTuples (Set.toList s') in+--                                            if sameExpr ts+--                                                then sConst (Cbool False)+                                                else Expr (Vand s')+    where+        filterNot :: [Expr] -> [Expr]+        filterNot [] = []+        filterNot (x:xs) = case view x of+                            Vnot n -> n : filterNot xs+                            _      ->     filterNot xs+        +        contains :: Set.Set Expr -> Expr -> Bool+        contains set (view -> Vand a) = all (`Set.member` set) (Set.toList a)+        contains set a                = Set.member a set+{-+        isCstrTuples :: [Expr] -> [(CstrId, Expr)]+        isCstrTuples [] = []+        isCstrTuples (x:xs) = case view x of+                                Viscstr c v -> (c,v) : isCstrTuples xs+                                _           ->         isCstrTuples xs+-}+        sameExpr :: [(CstrId, Expr)] ->  Bool+        sameExpr []     = False+        sameExpr (x:xs) = containExpr x xs+            where+                containExpr :: (CstrId, Expr) -> [(CstrId, Expr)] ->  Bool+                containExpr _      []             = False+                containExpr (c1,x1) ((c2,x2):cxs) = if x1 == x2 +                                                        then assert (c1 /= c2) True+                                                        else containExpr (c1,x1) cxs+-}++-- * Sum+isSum :: ExprView Integer -> Bool+isSum (Sum _) = True+isSum _ = False++getSum :: ExprView Integer -> FreeSum (ExprView Integer)+getSum (Sum s) = s+getSum _ = error "ExprImpls.hs - getSum - Unexpected Expr "++sSumInt :: FreeSum (Expr Integer) -> Expr Integer+sSumInt = Expr . cstrSum . FMX.mapTerms (SumTerm . view . summand)++-- | Apply operator sum on the provided sum of value expressions.+-- Preconditions are /not/ checked.+cstrSum :: FreeSum (ExprView Integer) -> ExprView Integer+-- implementation details:+-- Properties incorporated+--    at most one value: the value is the sum of all values+--         special case if the sum is zero, no value is inserted since v == v+0+--    remove all nested sums, since (a+b) + (c+d) == (a+b+c+d)+cstrSum ms = cstrSum' $ nonadds <> FMX.flatten sumOfAdds+    where+      (adds, nonadds) = FMX.partitionT isSum ms+      sumOfAdds :: FMX.FreeMonoidX (FMX.FreeMonoidX (SumTerm (ExprView Integer)))+      sumOfAdds = FMX.mapTerms (getSum . summand) adds++-- Sum doesn't contain elements of type VExprSum+cstrSum' :: FreeSum (ExprView Integer) -> ExprView Integer+cstrSum' ms =+    let (vals, nonvals) = FMX.partitionT isConst ms+        valueSum = FMX.mapTerms (SumTerm . getConst . summand) vals+        sumVals = summand $ FMX.foldFMX valueSum+        retMS = case sumVals of+                    0 -> nonvals                                      -- 0 + x == x+                    _ -> Sum.add (Const sumVals) nonvals+    in+        case FMX.toOccurList retMS of+            []         -> Const 0 -- sum of nothing equal zero+            [(term,1)] -> summand term+            _          -> Sum retMS++getConst :: ExprView e -> e+getConst (Const c) = c+getConst _ = error "Not Const"++isSumF :: ExprView Double -> Bool+isSumF (SumFloat _) = True+isSumF _ = False++getSumF :: ExprView Double -> FreeSum (ExprView Double)+getSumF (SumFloat s) = s+getSumF _ = error "ExprImpls.hs - getSumF - Unexpected Expr "++sSumFloat :: FreeSum (Expr Double) -> Expr Double+sSumFloat = Expr . cstrSumF . FMX.mapTerms (SumTerm . view . summand)++-- | Apply operator sum on the provided sum of floating-point values.+cstrSumF :: FreeSum (ExprView Double) -> ExprView Double+cstrSumF ms = cstrSumF' $ nonadds <> FMX.flatten sumOfAdds+    where+      (adds, nonadds) = FMX.partitionT isSumF ms+      sumOfAdds :: FMX.FreeMonoidX (FMX.FreeMonoidX (SumTerm (ExprView Double)))+      sumOfAdds = FMX.mapTerms (getSumF . summand) adds++cstrSumF' :: FreeSum (ExprView Double) -> ExprView Double+cstrSumF' ms =+    let (vals, nonvals) = FMX.partitionT isConst ms+        valueSum = FMX.mapTerms (SumTerm . getConst . summand) vals+        sumVals = summand $ FMX.foldFMX valueSum+        retMS = case sumVals of+                    0.0 -> nonvals                                   -- 0.0 + x == x+                    _   -> Sum.add (Const sumVals) nonvals+    in+        case FMX.toOccurList retMS of+            []         -> Const 0.0 -- sum of nothing equals zero+            [(term,1)] -> summand term+            _          -> SumFloat retMS++-- Product++-- | Is Expr a Product Expression?+isProduct :: ExprView Integer -> Bool+isProduct (Product _) = True+isProduct _ = False++getProduct :: ExprView Integer -> FreeProduct (ExprView Integer)+getProduct (Product p) = p+getProduct _ = error "ExprImpls.hs - getProduct - Unexpected Expr "++sProductInt :: FreeProduct (Expr Integer) -> Expr Integer+sProductInt = Expr . cstrPrd . FMX.mapTerms (ProductTerm . view . factor)++-- | Apply operator product on the provided product of value expressions.+-- Be aware that division is not associative for Integer, so only use power >= 0.+-- Preconditions are /not/ checked.+cstrPrd :: FreeProduct (ExprView Integer) -> ExprView Integer+-- implementation details:+-- Properties incorporated+--    at most one value: the value is the product of all values+--         special case if the product is one, no value is inserted since v == v*1+--    remove all nested products, since (a*b) * (c*d) == (a*b*c*d)+cstrPrd ms =+    cstrPrd' $ noprods <> FMX.flatten prodOfProds+    where+      (prods, noprods) = FMX.partitionT isProduct ms+      prodOfProds :: FMX.FreeMonoidX (FMX.FreeMonoidX (ProductTerm (ExprView Integer)))+      prodOfProds = FMX.mapTerms (getProduct . factor) prods++-- Product doesn't contain elements of type VExprProduct+cstrPrd' :: FreeProduct (ExprView Integer) -> ExprView Integer+cstrPrd' ms =+    let (vals, nonvals) = FMX.partitionT isConst ms+        (zeros, _) = FMX.partitionT isZero vals+    in+        case FMX.nrofDistinctTerms zeros of+            0   ->  -- let productVals = Product.foldPower timesVal 1 vals in+                    let intProducts = FMX.mapTerms (getConst <$>) vals+                        productVals = factor (FMX.foldFMX intProducts)+                    in+                        case FMX.toDistinctAscOccurListT nonvals of+                            []          ->  Const productVals+                            [(term, 1)] ->  cstrSum (FMX.fromOccurList [(SumTerm term, productVals)])                           -- term can be Sum -> rewrite needed+                            _           ->  cstrSum (FMX.fromOccurList [(SumTerm (Product nonvals), productVals)])  -- productVals can be 1 -> rewrite possible+            _   ->  let (_, n) = Product.fraction zeros in+                        case FMX.nrofDistinctTerms n of+                            0   ->  Const 0      -- 0 * x == 0+                            _   ->  error "Error in model: Division by Zero in Product (via negative power)"+    where+        isZero :: ExprView Integer -> Bool+        isZero (Const 0) = True+        isZero _         = False++-- Product of floating-point values+isProductF :: ExprView Double -> Bool+isProductF (ProductFloat _) = True+isProductF _ = False++getProductF :: ExprView Double -> FreeProduct (ExprView Double)+getProductF (ProductFloat p) = p+getProductF _ = error "ExprImpls.hs - getProductF - Unexpected Expr "++sProductFloat :: FreeProduct (Expr Double) -> Expr Double+sProductFloat = Expr . cstrPrdF . FMX.mapTerms (ProductTerm . view . factor)++-- | Apply operator product on the provided product of floating-point values.+cstrPrdF :: FreeProduct (ExprView Double) -> ExprView Double+cstrPrdF ms =+    cstrPrdF' $ noprods <> FMX.flatten prodOfProds+    where+      (prods, noprods) = FMX.partitionT isProductF ms+      prodOfProds :: FMX.FreeMonoidX (FMX.FreeMonoidX (ProductTerm (ExprView Double)))+      prodOfProds = FMX.mapTerms (getProductF . factor) prods++-- Product doesn't contain elements of type ProductFloat+cstrPrdF' :: FreeProduct (ExprView Double) -> ExprView Double+cstrPrdF' ms =+    let (vals, nonvals) = FMX.partitionT isConst ms+        (zeros, _) = FMX.partitionT isZeroF vals+    in+        case FMX.nrofDistinctTerms zeros of+            0   ->  let floatProducts = FMX.mapTerms (getConst <$>) vals+                        productVals = factor (FMX.foldFMX floatProducts)+                        withConst = if productVals == 1.0           -- 1.0 * x == x+                                        then nonvals+                                        else Product.multiply (Const productVals) nonvals+                    in+                        case FMX.toDistinctAscOccurListT withConst of+                            []          ->  Const productVals+                            [(term, 1)] ->  term+                            _           ->  ProductFloat withConst+            _   ->  let (_, n) = Product.fraction zeros in+                        case FMX.nrofDistinctTerms n of+                            0   ->  Const 0.0      -- 0.0 * x == 0.0+                            _   ->  error "Error in model: Division by Zero in Product (via negative power)"+    where+        isZeroF :: ExprView Double -> Bool+        isZeroF (Const 0.0) = True+        isZeroF _           = False++-- Divide++-- | Apply operator Divide on the provided integer value expressions.+-- Preconditions are /not/ checked.+divideInt :: Expr Integer -> Expr Integer -> Expr Integer+divideInt (view ->  Const t) (view -> Const n) | n /= 0 = sConst (t `Boute.div` n) -- leave error case (division by zero) unevaluated+divideInt (view -> vet)         (view -> ven) = Expr (Divide vet ven)++-- | Apply operator Divide on the provided floating-point value expressions.+-- Preconditions are /not/ checked.+divideFloat :: Expr Double -> Expr Double -> Expr Double+divideFloat (view ->  Const t) (view -> Const n) | n /= 0 = sConst (t / n) -- leave error case (division by zero) unevaluated+divideFloat (view -> vet)         (view -> ven) = Expr (DivideFloat vet ven)++-- Modulo++-- | Apply operator Modulo on the provided value expressions.+-- Preconditions are /not/ checked.+(.%) :: Expr Integer -> Expr Integer -> Expr Integer+(.%) (view -> Const t) (view -> Const n) | n /= 0 = sConst (t `Boute.mod` n) -- leave error case (division by zero) unevaluated+(.%) (view -> vet)        (view -> ven) = Expr (Modulo vet ven)++infixl 7 .%++-- | Apply operator GEZ (Greater Equal Zero) on the provided integer value expression.+-- Preconditions are /not/ checked.+sIsNonNegativeInt :: Expr Integer -> Expr Bool+-- Simplification Values+sIsNonNegativeInt (view -> Const v) = sConst (0 <= v)+sIsNonNegativeInt (view -> Length _)   = sConst True        -- length of string is always Greater or equal to zero+sIsNonNegativeInt (view -> ve)         = Expr (GezInt ve)++-- | Apply operator GEZ (Greater Equal Zero) on the provided floating-point value expression.+-- Preconditions are /not/ checked.+sIsNonNegativeFloat :: Expr Double -> Expr Bool+sIsNonNegativeFloat (view -> Const v) = sConst (0 <= v)+sIsNonNegativeFloat (view -> ve)      = Expr (GezFloat ve)++class Ord t => ExprNum t where+    sSum :: FreeSum (Expr t) -> Expr t+    sProduct :: FreeProduct (Expr t) -> Expr t+    sIsNonNegative :: Expr t -> Expr Bool+    (./) :: Expr t -> Expr t -> Expr t++infixl 7 ./++instance ExprNum Integer where+    sSum = sSumInt+    sProduct = sProductInt+    sIsNonNegative = sIsNonNegativeInt+    (./) = divideInt++instance ExprNum Double where+    sSum = sSumFloat+    sProduct = sProductFloat+    sIsNonNegative = sIsNonNegativeFloat+    (./) = divideFloat++-- | Apply operator Length on the provided value expression.+-- Preconditions are /not/ checked.+sLength :: Expr String -> Expr Integer+sLength (view -> Const s) = sConst (Prelude.toInteger (length s))+sLength (view -> v)             = Expr (Length v)++-- | Apply operator Concat on the provided sequence of value expressions.+-- Preconditions are /not/ checked.+sConcat :: [Expr String] -> Expr String+sConcat l =+    let n = (mergeVals . flatten . filter (sConst "" /= ) ) l in+        case n of+          [] -> sConst ""+          [x] -> x+          _ -> Expr (Concat $ fmap view n)++-- implementation details:+-- Properties incorporated+--    "" ++ x == x          - remove empty strings+--    "a" ++ "b" == "ab"    - concat consecutive string values+--   remove all nested sConcat, since (a ++ b) ++ (c ++ d) == (a ++ b ++ c ++ d)++mergeVals :: [Expr String] -> [Expr String]+mergeVals []            = []+mergeVals [x]           = [x]+mergeVals ( (view -> Const s1) : (view -> Const s2) : xs) =+                          mergeVals (sConst (s1 <> s2): xs)+mergeVals (x1:x2:xs)    = x1 : mergeVals (x2:xs)++flatten :: [Expr String] -> [Expr String]+flatten []                       = []+flatten ((view -> Concat l):xs) = fmap Expr l ++ flatten xs+flatten (x:xs)                   = x : flatten xs++-- | Apply String In Regular Expression operator on the provided value expressions.+-- Preconditions are /not/ checked.+--cstrStrInRe :: Expr -> Expr -> Expr+--cstrStrInRe (view -> Vconst (Cstring s)) (view -> Vconst (Cregex r)) = sConst (Cbool (T.unpack s =~ T.unpack (xsd2posix r) ) )+--cstrStrInRe s r                                                      = Expr (Vstrinre s r)++{-+-- | Create a call to a predefined function as a value expression.+cstrPredef :: PredefKind -> FuncId -> [Expr] -> Expr+cstrPredef p f a = Expr (Vpredef p f a)+-}++type TypedValuation t = Map.Map Variable t+data Valuation = Valuation {+    intValuation :: TypedValuation Integer,+    boolValuation :: TypedValuation Bool,+    stringValuation :: TypedValuation String,+    floatValuation :: TypedValuation Double+    }+    deriving (Eq, Ord)++instance Show Valuation where+    show (Valuation i b s f) = "{" ++ List.intercalate "," (printAsAssignments i ++ printAsAssignments b ++ printAsAssignments s ++ printAsAssignments f) ++ "}"+        where+        printAsAssignments :: Show t => Map.Map Variable t -> [String]+        printAsAssignments m = printAsAssignment <$> Map.toList m+        printAsAssignment (v,t) = varName v ++ ":=" ++ show t++toConstantsMap :: Valuation -> Map.Map Variable Constant+toConstantsMap valuation = Map.map Cint (intValuation valuation)+                            `Map.union` Map.map Cbool (boolValuation valuation)+                            `Map.union` Map.map Cstring (stringValuation valuation)+                            `Map.union` Map.map Cfloat (floatValuation valuation)++fromConstantsMap :: Map.Map Variable Constant -> Valuation+fromConstantsMap = assignValues . fmap (uncurry insertIntoValuation) . Map.toList++assignValues :: [Valuation -> Valuation] -> Valuation+assignValues = foldr ($) emptyValuation++emptyValuation :: Valuation+emptyValuation = Valuation Map.empty Map.empty Map.empty Map.empty++type TypedVarModel t = Map.Map Variable (Expr t)+data VarModel = VarModel {+    intVars :: TypedVarModel Integer,+    boolVars :: TypedVarModel Bool,+    stringVars :: TypedVarModel String,+    floatVars :: TypedVarModel Double+    }+    deriving (Eq, Ord)++assignment :: [VarModel -> VarModel] -> VarModel+assignment = foldr ($) noAssignment++typedValuationToVarModel :: ExprType t => TypedValuation t -> TypedVarModel t+typedValuationToVarModel = Map.map sConst++valuationToVarModel :: Valuation -> VarModel+valuationToVarModel vals = VarModel {+    intVars = typedValuationToVarModel $ intValuation vals,+    boolVars = typedValuationToVarModel $ boolValuation vals,+    stringVars = typedValuationToVarModel $ stringValuation vals,+    floatVars = typedValuationToVarModel $ floatValuation vals+    }++insertIntoValuation :: Variable -> Constant -> Valuation -> Valuation+insertIntoValuation v@(Variable name IntType) c = assignValue v (fromConst' c name IntType :: Integer)+insertIntoValuation v@(Variable name BoolType) c = assignValue v (fromConst' c name BoolType :: Bool)+insertIntoValuation v@(Variable name StringType) c = assignValue v (fromConst' c name StringType :: String)+insertIntoValuation v@(Variable name FloatType) c = assignValue v (fromConst' c name FloatType :: Double)+fromConst' :: (ConstType a, Show b) => Constant -> String -> b -> a+fromConst' smtValue name t = case fromConst smtValue of+    Left err -> error $ "error reading " ++ name ++ " as " ++ show t ++ ": " ++ err+    Right val -> val++class Assignable t where+    assign :: Variable -> Expr t -> VarModel -> VarModel+    assignValue :: Variable -> t -> Valuation -> Valuation+    assignedExpr :: Variable -> VarModel -> Maybe (Expr t)+    assignedExprWithDefault :: Variable -> VarModel -> Expr t++(=:) :: Assignable t => Variable -> Expr t -> VarModel -> VarModel+(=:) = assign+infixr 0 =:++instance Assignable Integer where+    assign v@(Variable _ IntType) e m = m {intVars = Map.insert v e (intVars m)}+    assign (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Integer, received " ++ show t+    assignValue v@(Variable _ IntType) val m = m {intValuation = Map.insert v val (intValuation m)}+    assignValue (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Integer, received " ++ show t+    assignedExpr v@(Variable _ IntType) (VarModel ints _bools _strings _floats) = Map.lookup v ints+    assignedExpr (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Integer"+    assignedExprWithDefault v@(Variable _ IntType) (VarModel ints _bools _strings _floats) = Map.findWithDefault (sVar v) v ints+    assignedExprWithDefault (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Integer"++instance Assignable Bool where+    assign v@(Variable _ BoolType) e m = m {boolVars = Map.insert v e (boolVars m)}+    assign (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Bool, received " ++ show t+    assignValue v@(Variable _ BoolType) val m = m {boolValuation = Map.insert v val (boolValuation m)}+    assignValue (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Bool, received " ++ show t+    assignedExpr v@(Variable _ BoolType) (VarModel _ints bools _strings _floats) = Map.lookup v bools+    assignedExpr (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Bool"+    assignedExprWithDefault v@(Variable _ BoolType) (VarModel _ints bools _strings _floats) = Map.findWithDefault (sVar v) v bools+    assignedExprWithDefault (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Bool"++instance Assignable String where+    assign v@(Variable _ StringType) e m = m {stringVars = Map.insert v e (stringVars m)}+    assign (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected String, received " ++ show t+    assignValue v@(Variable _ StringType) val m = m {stringValuation = Map.insert v val (stringValuation m)}+    assignValue (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected String, received " ++ show t+    assignedExpr v@(Variable _ StringType) (VarModel _ints _bools strings _floats) = Map.lookup v strings+    assignedExpr (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received String"+    assignedExprWithDefault v@(Variable _ StringType) (VarModel _ints _bools strings _floats) = Map.findWithDefault (sVar v) v strings+    assignedExprWithDefault (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received String"++instance Assignable Double where+    assign v@(Variable _ FloatType) e m = m {floatVars = Map.insert v e (floatVars m)}+    assign (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Real, received " ++ show t+    assignValue v@(Variable _ FloatType) val m = m {floatValuation = Map.insert v val (floatValuation m)}+    assignValue (Variable n t) _ _ = error $ "Assignment to '" ++ n ++ "' to wrong type: expected Real, received " ++ show t+    assignedExpr v@(Variable _ FloatType) (VarModel _ints _bools _strings floats) = Map.lookup v floats+    assignedExpr (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Real"+    assignedExprWithDefault v@(Variable _ FloatType) (VarModel _ints _bools _strings floats) = Map.findWithDefault (sVar v) v floats+    assignedExprWithDefault (Variable n t) _ = error $ "Assignment from '" ++ n ++ "' to wrong type: expected " ++ show t ++ ", received Real"++noAssignment :: VarModel+noAssignment = VarModel Map.empty Map.empty Map.empty Map.empty++instance Show VarModel where+    show (VarModel ints bools strings floats) = showMapList $ showList' ints ++ showList' bools ++ showList' strings ++ showList' floats+        where+        showMapList m' = "{" ++ List.intercalate ", " m' ++ "}"+        showList' m' = showAssign <$> Map.toList m'+        showAssign (v,e) = varName v ++ ":=" ++ show e++substConst :: Assignable t => Valuation -> Expr t -> Expr t+substConst valuation = subst (valuationToVarModel valuation)++-- | Substitute variables by value expressions in a value expression.+--+-- Preconditions are /not/ checked.+--+subst :: Assignable t => VarModel      -- ^ Map from variables to value expressions.+{-      -> Map.Map FuncId (FuncDef w e) -- ^ Map from identifiers to their+                                    -- definitions, this is used to replace+                                    -- function calls by their bodies if all+                                    -- the arguments of the function are+                                    -- constant.-}+      -> Expr t                -- ^ Value expression where the+                                    -- substitution will take place.+      -> Expr t+--subst ve _ x   | ve == Map.empty = x+subst ve x = subst' ve (view x)++subst' :: Assignable t => VarModel -> ExprView t -> Expr t+subst' _  (Const const')          = sConst const'+subst' ve (Var vid)               = assignedExprWithDefault vid ve+subst' ve (Ite cond vexp1 vexp2)  = sIfThenElse (subst' ve cond) (subst' ve vexp1) (subst' ve vexp2)+subst' ve (Divide t n)            = (./) (subst' ve t) (subst' ve n)+subst' ve (Modulo t n)            = (.%) (subst' ve t) (subst' ve n)+subst' ve (DivideFloat t n)       = (./) (subst' ve t) (subst' ve n)+subst' ve (Sum s)                 = sSum $ FMX.fromOccurListT $ map (first (subst' ve)) $ FMX.toDistinctAscOccurListT s+subst' ve (SumFloat s)            = sSum $ FMX.fromOccurListT $ map (first (subst' ve)) $ FMX.toDistinctAscOccurListT s+subst' ve (Product p)             = sProduct $ FMX.fromOccurListT $ map (first (subst' ve)) $ FMX.toDistinctAscOccurListT p+subst' ve (ProductFloat p)        = sProduct $ FMX.fromOccurListT $ map (first (subst' ve)) $ FMX.toDistinctAscOccurListT p+subst' ve (Length vexp)           = sLength (subst' ve vexp)++subst' ve (GezInt v)                = sIsNonNegative (subst' ve v)+subst' ve (GezFloat v)              = sIsNonNegative (subst' ve v)+subst' ve (EqualInt vexp1 vexp2)    = (.==) (subst' ve vexp1) (subst' ve vexp2)+subst' ve (EqualBool vexp1 vexp2)   = (.==) (subst' ve vexp1) (subst' ve vexp2)+subst' ve (EqualString vexp1 vexp2) = (.==) (subst' ve vexp1) (subst' ve vexp2)+subst' ve (EqualFloat vexp1 vexp2)  = (.==) (subst' ve vexp1) (subst' ve vexp2)+subst' ve (And vexps)               = sAnd $ Set.map (subst' ve) vexps+subst' ve (Not vexp)                = sNot (subst' ve vexp)++subst' ve (Concat vexps)                = sConcat $ map (subst' ve) vexps
+ src/Lattest/Model/Symbolic/Internal/ExprImplsExtension.hs view
@@ -0,0 +1,159 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}++{-# LANGUAGE FlexibleInstances #-}++module Lattest.Model.Symbolic.Internal.ExprImplsExtension+( -- * Derived Boolean operators+  -- ** Or (\/)+  sOr+, (.&&)+, (.||)+  -- ** Exclusive or (\|/)+, sXor+  -- ** Implies (=>)+, (.=>)+  -- * Derived Integer operators:+  -- ** Unary Minus = negate single argument+, sNeg+  -- ** Plus = Sum of two terms+, (.+)+  -- ** Minus+, (.-)+  -- ** Times = Product of two terms+, (.*)+  -- ** Absolute value+, sAbs+  -- * Derived Integer comparisons+  -- ** Less than (<)+, (.<)+  -- ** Less Equal (<=)+, (.<=)+  -- ** Greater Equal (>=)+, (.>=)+  -- ** Greater Than (>)+, (.>)+)+where++import qualified Data.Set     as Set++import           Lattest.Model.Symbolic.Internal.FreeMonoidX+import           Lattest.Model.Symbolic.Internal.ExprDefs+import           Lattest.Model.Symbolic.Internal.ExprImpls+++-- | Apply operator Or (\\\/) on the provided set of value expressions.+-- Preconditions are /not/ checked.+sOr :: Set.Set (Expr Bool) -> Expr Bool+-- a \/ b == not (not a /\ not b)+sOr = sNot . sAnd . Set.map sNot++(.&&) :: Expr Bool -> Expr Bool -> Expr Bool+(.&&) a b = sAnd $ Set.fromList [a,b]++infixr 3 .&&++(.||) :: Expr Bool -> Expr Bool -> Expr Bool+(.||) a b = sOr $ Set.fromList [a,b]++infixr 2 .||++-- | Apply operator Xor (\\\|/) on the provided set of value expressions.+-- Preconditions are /not/ checked.+sXor :: Expr Bool -> Expr Bool -> Expr Bool+sXor a b = sOr (Set.fromList [ sAnd (Set.fromList [a, sNot b])+                                   , sAnd (Set.fromList [sNot a, b])+                                   ])++-- | Apply operator Implies (=>) on the provided value expressions.+-- Preconditions are /not/ checked.+(.=>) :: Expr Bool -> Expr Bool -> Expr Bool+-- a => b == not a \/ b == not (a /\ not b)+(.=>) a b = (sNot . sAnd) (Set.insert a (Set.singleton (sNot b)))++infixr 1 .=>++instance Num (Expr Integer) where+    fromInteger = sConst+    (-) = (.-)+    (+) = (.+)+    (*) = (.*)+    negate = sNeg+    abs = sAbs+    signum x = sIfThenElse (x .< 0) (-1) (sIfThenElse (x .> 0) 1 0)++instance Num (Expr Double) where+    fromInteger = sConst . fromInteger+    (-) = (.-)+    (+) = (.+)+    (*) = (.*)+    negate = sNeg+    abs = sAbs+    signum x = sIfThenElse (x .< 0) (-1) (sIfThenElse (x .> 0) 1 0)++-- | Apply unary operator Minus on the provided value expression.+-- Preconditions are /not/ checked.+sNeg :: ExprNum t => Expr t -> Expr t+sNeg v = sSum (fromOccurListT [(v,-1)])++-- | Apply operator Add on the provided value expressions.+-- Preconditions are /not/ checked.+(.+) :: ExprNum t => Expr t -> Expr t -> Expr t+(.+) a b = sSum (fromListT [a,b])++infixl 6 .+++-- | Apply operator Minus on the provided value expressions.+-- Preconditions are /not/ checked.+(.-) :: ExprNum t => Expr t -> Expr t -> Expr t+(.-) a b = sSum (fromOccurListT [(a,1),(b,-1)])++infixl 6 .-++-- | Apply operator Times on the provided value expressions.+-- Preconditions are /not/ checked.+(.*) :: ExprNum t => Expr t -> Expr t -> Expr t+(.*) a b = sProduct (fromListT [a,b])++infixl 7 .*++-- | Apply operator Absolute value (abs) on the provided value expression.+-- Preconditions are /not/ checked.+sAbs :: ExprNum t => Expr t -> Expr t+sAbs a = sIfThenElse (sIsNonNegative a) a (sNeg a)++-- | Apply operator LT (<) on the provided value expression.+-- Preconditions are /not/ checked.+(.<) :: ExprNum t => Expr t -> Expr t -> Expr Bool+-- a < b <==> a - b < 0 <==> Not ( a - b >= 0 )+ve1 .< ve2 = sNot $ sIsNonNegative $ sSum $ fromOccurListT [(ve1,1),(ve2,-1)]++infix 4 .<++-- | Apply operator GT (>) on the provided value expression.+-- Preconditions are /not/ checked.+(.>) :: ExprNum t => Expr t -> Expr t -> Expr Bool+-- a > b <==> 0 > b - a <==> Not ( 0 <= b - a )+ve1 .> ve2 = sNot $ sIsNonNegative $ sSum $ fromOccurListT [(ve1,-1),(ve2,1)]++infix 4 .>++-- | Apply operator LE (<=) on the provided value expression.+-- Preconditions are /not/ checked.+(.<=) :: ExprNum t => Expr t -> Expr t -> Expr Bool+-- a <= b <==> 0 <= b - a+ve1 .<= ve2 = sIsNonNegative $ sSum $ fromOccurListT [(ve1,-1),(ve2,1)]++infix 4 .<=++-- | Apply operator GE (>=) on the provided value expression.+-- Preconditions are /not/ checked.+(.>=) :: ExprNum t => Expr t -> Expr t -> Expr Bool+-- a >= b <==> a - b >= 0+ve1 .>= ve2 = sIsNonNegative $ sSum $ fromOccurListT [(ve1,1),(ve2,-1)]++infix 4 .>=
+ src/Lattest/Model/Symbolic/Internal/FreeMonoidX.hs view
@@ -0,0 +1,327 @@+{-# OPTIONS_HADDOCK hide, prune #-}+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  FreeMonoidX+-- Copyright   :  (c) TNO and Radboud University+-- License     :  BSD3 (see the file license.txt)+--+-- Maintainer  :  damian.nadales@gmail.com (Embedded Systems Innovation by TNO)+-- Stability   :  experimental+-- Portability :  portable+--+--  Free commutative Monoid with a multiplication operation. Symbolic representation of+--  free-monoids of the form:+--+-- > a0 <> a1 <> ... <> an-1+--+-- `ai \in A`, `<>` is a commutative (binary) operation, `(A, <>)` is a+-- Monoid, there is a multiplication operator `<.>` that is distributive+-- w.r.t `<>`, and there is additive inverse for the elements of `A`:+--+-- > a <> b         = b <> a                 -- for all a, b in A (commutativity)+-- > a <.> (b <> c) = (a <.> b) <> (a <.> c) -- for all a, b, c in A (left distributivity).+-- > (b <> c) <.> a = (b <.> a) <> (c <.> a) -- for all a, b, c in A (right distributivity).+-- > a <> -a        = 0                      -- for all a, for some (-a), where `0 = mempty`.+--+-- Furthermore, to be able to assign semantics to this symbolic representation+-- it is required that the terms are integer-multipliable, meaning that+--+-- > `a <.> n`+--+-- is equivalent to adding an element `a` `n` times if `n` is non-negative, or+-- removing it `n` times otherwise. See `IntMultipliable` class, and+-- `multiplyLaw` in `FreeMonoidXSpec`.+--+-- Note that we're using `<.>` as having both types `A -> A` and `Integral n =>+-- n -> a`, which is fine at the moment since the `FreeMonoidX`'s we are+-- dealing with are numeric types.+--+--+-- `FreeMonoidX a` is an instance of the `IsList` class, which means that in+-- combination with the `OverloadedLists` extension is possible to write+-- free-monoids as lists. For instance the free-monoid:+--+-- > a0 <> a1 <> ... <> an-1+--+-- Can be written as+--+-- [a0, a1, ..., an-1]+--+-----------------------------------------------------------------------------++module Lattest.Model.Symbolic.Internal.FreeMonoidX+  ( -- * Free Monoid with multiplication Type+    FreeMonoidX (..)++  -- * Query+  , nrofDistinctTerms+  , distinctTerms  -- exposed for performance reasons checking properties for+                   -- all distinct terms is faster than for all terms+  , distinctTermsT+  , allFreeMonoidX+  -- * Map+  , mapTerms+  , mapFreeMonoidX++  -- * Filter+  , partition+  , partitionT++  -- * Folds+  , foldrTerms+  , foldOccur+  , foldFMX+  , Lattest.Model.Symbolic.Internal.FreeMonoidX.fold++    -- * Manipulation of the free monoid+  , append+  , remove+  , appendMany+  , flatten++  -- * Multiplication operator+  , (<.>)++  -- * Monoid terms restriction+  , IntMultipliable+  , TermWrapper (..)++  -- * Occurrence lists+  , toOccurList+  , toDistinctAscOccurList+  , fromOccurList+  , fromDistinctAscOccurList+  -- ** Occurrence lists of `TermWrapper`'s+  , fromListT+  , toOccurListT+  , toDistinctAscOccurListT+  , fromOccurListT+  , fromDistinctAscPowerListT+  -- ** Lists of direct items+  , GHC.Exts.toList+  , GHC.Exts.fromList+  )+where++import           Control.Arrow   (first, (***))+import           Data.Data+import           Data.Foldable+import Data.List (genericReplicate)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           GHC.Exts+import           GHC.Generics    (Generic)++-- | Symbolic representation of a polynomial, where each term is a member of+-- type `a`.+--+-- The integer value of the map represents the number of occurrences of a term+-- in the polynomial. Given this representation it is crucial that the+-- operation is commutative, since the information of about the order of the+-- term is lost in this representation.+--+newtype FreeMonoidX a = FMX { asMap :: Map a Integer }+    deriving (Eq, Ord, Read, Generic, Data)++-- | A term of the monoid which wraps a value. This could be for instance a+-- sum-term or a product term.+class TermWrapper f where+    wrap :: a -> f a+    unwrap :: f a -> a++-- | Types that can be multiplied by an integral. This restriction is required+-- to be able to assign a correct semantic to the symbolic representation of+-- the free-monoid. If the elements of the free-monoid are not+-- `IntMultipliable`, then `foldFMX` is ill-defined.+--+-- See the test code `FreeMonoidXspec` for examples of instances of this class.+class IntMultipliable a where+    -- | `n <.> x` multiplies `x` `n` times.+    (<.>) :: Integral n+         => n -- ^ Multiplication factor.+         -> a -- ^ Element to multiply.+         -> a++instance Ord a => IntMultipliable (FreeMonoidX a) where+    0 <.> _ = mempty+    n <.> (FMX p) = FMX $ (toInteger n *) <$> p++instance Ord a => Semigroup (FreeMonoidX a) where+    FMX p0 <> FMX p1 = FMX $ Map.filter (/= 0) $ Map.unionWith (+) p0 p1++instance Ord a => Monoid (FreeMonoidX a) where+    mempty = FMX []+++instance Ord a => IsList (FreeMonoidX a) where+    type Item (FreeMonoidX a) = a+    fromList xs = FMX $ Map.fromListWith (+) $ map (,1) xs+    toList (FMX p) = do+        (x, n) <- Map.toList p+        genericReplicate n x++-- | /O(t*log t)/. Create a product from a list of terms using the given term+-- wrapper.+fromListT :: (Ord (t a), TermWrapper t) => [a] -> FreeMonoidX (t a)+fromListT = fromList . (wrap <$>)++-- | Fold the free-monoid.+foldFMX :: (IntMultipliable a, Monoid a) => FreeMonoidX a -> a+foldFMX (FMX p) = Map.foldrWithKey (\x n -> (n <.> x <>)) mempty p++-- | Fold the free-monoid of term wrappers.+fold :: (IntMultipliable (t a), Monoid (t a), TermWrapper t) => FreeMonoidX (t a) -> a+fold = unwrap . foldFMX++-- | Number of distinct terms in the free-monoid.+nrofDistinctTerms :: FreeMonoidX a -> Int+nrofDistinctTerms = Map.size . asMap++-- | /O(n)/. The distinct terms of a free-monoid., each term occurs only once in+-- the list.+--+distinctTerms :: FreeMonoidX a -> [a]+distinctTerms = Map.keys . asMap++distinctTermsT :: TermWrapper t => FreeMonoidX (t a) -> [a]+distinctTermsT = (unwrap <$>) . distinctTerms++-- | /O(n)/. Convert the free-monoid to a list of (term, occurrence) tuples.+--+-- For instance given the term:+--+-- > a <> b <> a <> b <> a+--+-- `toOccurList` applied to it will result in the following list:+--+-- > [(a, 3), (b, 2)]+--+toOccurList :: FreeMonoidX a -> [(a, Integer)]+toOccurList = toDistinctAscOccurList++toOccurListT :: TermWrapper t => FreeMonoidX (t a) -> [(a, Integer)]+toOccurListT = (first unwrap <$>) . toDistinctAscOccurList++-- | /O(n)/. Convert the free-monoid to a distinct ascending list of term\/multiplier+-- pairs.+toDistinctAscOccurList :: FreeMonoidX a -> [(a, Integer)]+toDistinctAscOccurList = Map.toAscList . asMap++toDistinctAscOccurListT :: TermWrapper t => FreeMonoidX (t a) -> [(a, Integer)]+toDistinctAscOccurListT = (first unwrap <$>) . toDistinctAscOccurList++-- | /O(n*log n)/. Create a free-monoid from a list of term\/multiplier pairs.+fromOccurList :: Ord a => [(a, Integer)] -> FreeMonoidX a+fromOccurList = FMX . Map.filter (0/=) . Map.fromListWith (+)++fromOccurListT :: (Ord (t a), TermWrapper t) => [(a, Integer)] -> FreeMonoidX (t a)+fromOccurListT = fromOccurList . (first wrap <$>)++-- | /O(n)/. Build a free-monoid from an ascending list of term\/multiplier+-- pairs where each term appears only once. /The precondition (input list is+-- strictly ascending) is not checked./+fromDistinctAscOccurList :: [(a, Integer)] -> FreeMonoidX a+fromDistinctAscOccurList = FMX . Map.filter (0/=) . Map.fromDistinctAscList++fromDistinctAscPowerListT :: TermWrapper t => [(a, Integer)] -> FreeMonoidX (t a)+fromDistinctAscPowerListT = fromDistinctAscOccurList . (first wrap <$>)++-- | Append a term to the free-monoid.+--+-- > append 2 [1, 2, 3]+--+-- should be equivalent to the free-monoid.+--+-- > [1, 2, 3, 2]+append :: Ord a => a -> FreeMonoidX a -> FreeMonoidX a+append = appendMany 1++-- | Remove a term from the free-monoid.+--+-- > remove 2 (1 <> 2 <> 3)+--+-- should be equivalent to the free-monoid+--+-- > (1 <> 3)+remove :: Ord a => a -> FreeMonoidX a -> FreeMonoidX a+remove = appendMany (-1)++-- | Add the term `x` `n` times. If `n` is negative the term will be removed+-- `n` times.+--+-- > appendMany 2 10 (10 <> 12 <> 12)+--+-- should be equivalent to+--+-- (10 <> 10 <> 10 <> 12 <> 12)+--+-- > appendMany (-2) 10 (10 <> 12 <> 12)+--+-- should be equivalent to+--+-- > (-10 <> 12 <> 12)+appendMany :: Ord a => Integer -> a -> FreeMonoidX a -> FreeMonoidX a+appendMany 0 _ s = s                                    -- invariant: no term with multiplier 0 is stored.+appendMany m x s = (FMX . Map.alter increment x . asMap) s+    where+        increment :: Maybe Integer -> Maybe Integer+        increment Nothing  = Just m+        increment (Just n) | n == -m = Nothing           -- Terms with multiplier zero are removed+        increment (Just n) = Just (n+m)++-- | /O(n)/. Partition the free-monoid into two free-monoids, one with all+-- elements that satisfy the predicate and one with all elements that don't+-- satisfy the predicate.+partition :: (a -> Bool) -> FreeMonoidX a -> (FreeMonoidX a,FreeMonoidX a)+partition p = (FMX *** FMX) . Map.partitionWithKey (\k _ -> p k) . asMap++partitionT :: TermWrapper t => (a -> Bool) -> FreeMonoidX (t a)+           -> (FreeMonoidX (t a), FreeMonoidX (t a))+partitionT p = partition (p . unwrap)++-- | /O(n)/. Fold over the terms of the free-monoid with their multipliers.+foldOccur :: (a -> Integer -> b -> b) -> b -> FreeMonoidX a -> b+foldOccur f z = Map.foldrWithKey f z . asMap++foldrTerms :: (TermWrapper f) => (a -> b -> b) -> b -> FreeMonoidX (f a) -> b+foldrTerms f e = foldr f e . distinctTermsT++-- | Map the terms of the free-monoid.+--+mapTerms :: Ord b => (a -> b) -> FreeMonoidX a -> FreeMonoidX b+mapTerms f = fromOccurList . (first f <$>) . toOccurList++mapFreeMonoidX :: (Functor f, Ord (f b)) => (a -> b) -> FreeMonoidX (f a) -> FreeMonoidX (f b)+mapFreeMonoidX f = mapTerms (fmap f)++allFreeMonoidX :: (TermWrapper f) => (a -> Bool) -> FreeMonoidX (f a) -> Bool+allFreeMonoidX p = all p . distinctTermsT++-- | Flatten a free-monoid.+--+-- For instance, the monoid+--+-- > (a <> b) <> (a <> b) <> a+--+-- will be rewritten as:+--+-- > a <> a <> a <> b <> b+--+-- Assuming `a < b`.+--+flatten :: (Ord a) => FreeMonoidX (FreeMonoidX a) -> FreeMonoidX a+flatten (FMX p) = Data.Foldable.fold $ multiplyFMX <$> Map.toAscList p+    where+      multiplyFMX :: Ord a => (FreeMonoidX a, Integer) -> FreeMonoidX a+      multiplyFMX (fm, n) = n <.> fm
+ src/Lattest/Model/Symbolic/Internal/Product.hs view
@@ -0,0 +1,115 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Lattest.Model.Symbolic.Internal.Product  (+    -- * Product type+      FreeProduct+    , ProductTerm (..)++    -- * Filter+    , fraction++    -- * Product of Term and Products+    , multiply+    , divide+    , product+    , products++    -- * Power+    , power+) where++import           Control.Arrow   ((***))+import           Data.Data+import           Data.Foldable   hiding (product)+import qualified Data.Map.Strict as Map+import           Data.Monoid     hiding ((<>))+import           Data.Semigroup+import           GHC.Generics    (Generic)+import           Prelude         hiding (product)++import           Lattest.Model.Symbolic.Internal.FreeMonoidX     (FreeMonoidX (..), IntMultipliable,+                                  TermWrapper, (<.>))+import qualified Lattest.Model.Symbolic.Internal.FreeMonoidX     as FMX++{--------------------------------------------------------------------+  The data types+--------------------------------------------------------------------}+-- |+-- `FreeProduct` represents a symbolic product of terms of the type parameter `a`.+-- The same term can occur multiple times.+type FreeProduct a = FreeMonoidX (ProductTerm a)++-- | Terms of a free-monoids of the form:+--+-- > a0 <> a1 <> ... <> an-1+--+-- where `<>` will be interpreted as the arithmetic multiplication of terms:+--+-- > a0 * a1 * ... * an-1+--+newtype ProductTerm a = ProductTerm { factor :: a }+    deriving (Eq, Ord, Read, Generic, Functor, Data)++instance Show a => Show (ProductTerm a) where+    show = show . factor++instance Applicative ProductTerm where+    pure = ProductTerm+    fa <*> a = ProductTerm $ factor fa (factor a)++instance Num a => Semigroup (ProductTerm a) where+    pt0 <> pt1 = (*) <$> pt0 <*> pt1++instance Num a => Monoid (ProductTerm a) where+    mempty = pure 1++instance TermWrapper ProductTerm where+    wrap = ProductTerm+    unwrap = factor++instance Num a => IntMultipliable (ProductTerm a) where+    n <.> pt = (^ toInteger n) <$> pt++instance Foldable ProductTerm where+    --foldr :: (a -> b -> b) -> b -> t a -> b +    foldr f e (ProductTerm x) = f x e++{--------------------------------------------------------------------+  Products and multiplications+--------------------------------------------------------------------}+-- | /O(log n)/. Multiply a product with a term.+multiply :: Ord a => a -> FreeProduct a -> FreeProduct a+multiply = FMX.append . ProductTerm++-- | /O(log n)/. Divide a product by a term.+divide :: Ord a => a -> FreeProduct a -> FreeProduct a+divide = FMX.remove . ProductTerm++-- | The product of a list of products.+products :: Ord a => [FreeProduct a] -> FreeProduct a+products = fold++-- | /O(n+m)/. The product of two products.+--+product :: Ord a => FreeProduct a -> FreeProduct a -> FreeProduct a+product = (<>)++-- | /O(n)/. Take the product /ms/ to the power with the constant /x/.+power :: Ord a => Integer -> FreeProduct a -> FreeProduct a+power = (<.>)+++{--------------------------------------------------------------------+  Partition+--------------------------------------------------------------------}+-- | /O(n)/. Partition the product into the dividend and divisor.+fraction :: Ord a => FreeProduct a -> (FreeProduct a, FreeProduct a)+fraction =+    (FMX *** (power (-1). FMX) ) . Map.partition (>= 0) . asMap
+ src/Lattest/Model/Symbolic/Internal/Sum.hs view
@@ -0,0 +1,94 @@+{-+This is a modified version of:+TorXakis - Model Based Testing+See LICENSE in the parent Symbolic folder.+-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Lattest.Model.Symbolic.Internal.Sum+    (  -- * Sum types+      FreeSum+    , SumTerm (..)++    -- * Sum of Term and Sums+    , add+    , subtract+    , sum+    , sums++    -- * Multiply+    , multiply+    ) where++import           Data.Data+import           Data.Foldable   hiding (sum)+import           Lattest.Model.Symbolic.Internal.FreeMonoidX     (FreeMonoidX, IntMultipliable, TermWrapper,+                                  (<.>))+import qualified Lattest.Model.Symbolic.Internal.FreeMonoidX     as FMX+import           GHC.Generics    (Generic)+import           Prelude         hiding (subtract, sum)++{--------------------------------------------------------------------+  The data types+--------------------------------------------------------------------}+-- | `FreeSum` represents a symbolic sum of terms of the type parameter `a`.+-- The same term can occur multiple times.+--+type FreeSum a = FreeMonoidX (SumTerm a)++-- | Terms of a free-monoids of the form:+--+-- > a0 <> a1 <> ... <> an-1+--+-- where `<>` will be interpreted as the arithmetic sum of terms:+--+-- > a0 + a1 + ... + an-1+--+newtype SumTerm a = SumTerm { summand :: a }+    deriving (Eq, Ord, Read, Generic, Functor, Data)++instance Show a => Show (SumTerm a) where+    show = show . summand++instance Num a => Semigroup (SumTerm a) where+    (SumTerm x) <> (SumTerm y) = SumTerm $ x + y++instance Num a => Monoid (SumTerm a) where+    mempty = SumTerm 0++instance TermWrapper SumTerm where+    wrap = SumTerm+    unwrap = summand++-- TODO: Rename to NumMultipliable?+instance Num a => IntMultipliable (SumTerm a) where+    n <.> SumTerm x = SumTerm (fromInteger (toInteger n) * x)++instance Foldable SumTerm where+    --foldr :: (a -> b -> b) -> b -> t a -> b +    foldr f e (SumTerm x) = f x e++{--------------------------------------------------------------------+  Sums and multiplications+--------------------------------------------------------------------}+-- | /O(log n)/. Add a term to a sum.+add :: Ord a => a -> FreeSum a -> FreeSum a+add = FMX.append . SumTerm++-- | /O(log n)/. Subtract a term from a sum.+subtract :: Ord a => a -> FreeSum a -> FreeSum a+subtract = FMX.remove . SumTerm++-- | The sum of a list of sums.+sums :: (Ord a) => [FreeSum a] -> FreeSum a+sums = fold++-- | /O(n+m)/. The sum of two sums.+sum :: Ord a => FreeSum a -> FreeSum a -> FreeSum a+sum = (<>)++-- | /O(n)/. Multiply the constant with the sum.+multiply :: Ord a => Integer -> FreeSum a -> FreeSum a+multiply = (<.>)
+ src/Lattest/Model/Symbolic/SolveSTS.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Find concrete values to take transitions in STSes, using an SMT solver.+-}++module Lattest.Model.Symbolic.SolveSTS (+solveRandomInteraction,+)+where++import Lattest.Model.Alphabet(SymInteract(..), GateValue(..), SymGuard)+import Lattest.Model.Automaton(stateConf, IntrpState(..), transRel, AutomatonException(ActionOutsideAlphabet), STStdest(STSLoc), syntacticAutomaton, alphabet, AutIntrpr)+import Lattest.Model.BoundedMonad(BooleanConfiguration, asDualExpr)+import qualified Lattest.Model.BoundedMonad as BM+import Lattest.Model.StandardAutomata(STS)+import Lattest.Model.Symbolic.SolveSymPrim(solveAnySequential)+import Lattest.Model.Symbolic.Expr(substConst, Expr(..))+import Lattest.SMT(SMT)+import Lattest.Util.Utils(distributeFirstMaybe)++import Control.Arrow((&&&))+import Control.Exception(throw)++import Data.Foldable(toList)+import qualified Data.Map as Map+import GHC.Stack(callStack)+import List.Shuffle(shuffle)+import System.Random(RandomGen)+import Data.Maybe (mapMaybe)++{-|+    For the given STS and a subset function, using SMT solving, find a interaction of the STS in that subset for which the guard is true from the+    current STS state. The interaction is picked uniformly randomly among interactions with satisfied gates, if any. This uses the supplied random +    generator and returns the new random generator state. The returned gate values for that interaction are not randomized in any way, picking values+    is left to the SMT solver.+-}+solveRandomInteraction :: (BM.OrdMonad m, BooleanConfiguration m, Ord g, Ord (m (Expr Bool)), RandomGen r) => AutIntrpr m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g'') -> (SymInteract g -> Maybe (SymInteract g')) -> r -> SMT (Maybe (GateValue g'), r)+solveRandomInteraction intrpr subsetFunction r = do+    let interactionsWithGuards = selectInteractionsAndGuards intrpr subsetFunction+        (interactionsWithGuards', r') = shuffle interactionsWithGuards r+    (,r') <$> solveAnySequential interactionsWithGuards' -- prepend the new random state to the solved result+    where+    -- select the subset of gates according to the subsetFunction, together with the guards from the current state configuration according to the STS interpretation+    selectInteractionsAndGuards :: (BM.OrdMonad m, BooleanConfiguration m, Ord g, Ord (m (Expr Bool))) => AutIntrpr m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g'') -> (SymInteract g -> Maybe (SymInteract g')) -> [(SymInteract g', SymGuard)]+    selectInteractionsAndGuards intrpr' subsetFunction' =+        let alph = toList $ alphabet $ syntacticAutomaton intrpr'+        in mapMaybe (distributeFirstMaybe . (subsetFunction' &&& interactToGuard intrpr')) alph++interactToGuard :: (BM.OrdMonad m, BooleanConfiguration m, Ord g, Ord (m (Expr Bool))) => AutIntrpr m loc (IntrpState loc) (SymInteract g) STStdest (GateValue g') -> SymInteract g -> SymGuard+interactToGuard intrpr interaction = let+        aut = syntacticAutomaton intrpr+    in asDualExpr $ BM.ordJoin $ stateAndInteractToGuards aut interaction BM.<#> stateConf intrpr++stateAndInteractToGuards :: (Ord g, BM.OrdFunctor m) => STS m loc g -> SymInteract g -> IntrpState loc -> m SymGuard+stateAndInteractToGuards aut interaction (IntrpState l valuation) =+    case Map.lookup interaction (transRel aut l) of+        Nothing -> throw $ ActionOutsideAlphabet callStack+        Just mtdestloc -> BM.ordMap guardAndLocToGuard mtdestloc+    where+    guardAndLocToGuard (STSLoc (tguard,_), _) = substConst valuation tguard+++
+ src/Lattest/Model/Symbolic/SolveSymPrim.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK hide, prune #-}+module Lattest.Model.Symbolic.SolveSymPrim (+combineGuards,+substituteInGuard,+evaluateGuard,+solveAnySequential,+solveGuard+) where++import Lattest.Model.Alphabet(SymInteract(..), GateValue(..), SymGuard)+import Lattest.Model.BoundedMonad(BooleanConfiguration, OrdFunctor, asDualExpr)+import qualified Lattest.Model.Symbolic.Expr as E+import Lattest.Model.Symbolic.Expr(Valuation,Variable(..))+import Lattest.Model.Symbolic.Internal.ExprDefs(eval)+import Lattest.Model.Symbolic.Internal.ExprImpls(substConst)+import Lattest.SMT(pop,getSolution,addAssertions,addDeclarations,getSolvable,push,SolvableProblem(..),SMT)++import qualified Data.Map as Map++{-|+    Combine the given guards into one.+-}+combineGuards :: (BooleanConfiguration m, OrdFunctor m) => m SymGuard -> SymGuard+combineGuards = asDualExpr++{-|+    In the given guard, substitute the given valuation.+-}+substituteInGuard :: Valuation -> SymGuard -> SymGuard+--substituteInGuard valuation guard = evalConst' valuation guard+substituteInGuard = substConst++{-|+    Evaluate the given guard+-}+evaluateGuard :: SymGuard -> Bool+evaluateGuard guard = case eval guard of+    Left e -> error e -- TODO proper exception+    Right b -> b++{-|+    For the given list of interactions and guards, using SMT solving, pick the first interaction in that list for which the guard is satisfiable, if+    any. The returned gate values for that interaction are not randomized in any way, picking values is left to the SMT solver.+-}+solveAnySequential :: [(SymInteract g,SymGuard)] -> SMT (Maybe (GateValue g))+solveAnySequential [] = return Nothing+solveAnySequential ((interact'@(SymInteract _ vars),guard):alph) = do+    maybeSolved <- solveGuard vars guard+    case maybeSolved of+        Nothing -> solveAnySequential alph+        Just solved -> return $ Just $ valuationToGateValue interact' solved+--data SymInteract g = SymInteract g [Variable]+--data GateValue g = GateValue g [Constant]+valuationToGateValue :: SymInteract g -> Valuation -> GateValue g+valuationToGateValue (SymInteract g' params) valuation =+    GateValue g' $ fmap (getValueForVar $ E.toConstantsMap valuation) params+    where+        getValueForVar val' var =+            case Map.lookup var val' of+                Just value -> value+                Nothing -> undefined  "valuationToGateValue: wrong type" -- TODO throw exception. Static type checking is infeasible due to external SMT solving. Should not happen if SMT solver behaves properly.++solveGuard :: [Variable] -> SymGuard -> SMT (Maybe Valuation)+solveGuard vars guard = do+    push+    addDeclarations vars+    addAssertions [guard]+    solveOutcome <- getSolvable+    mSolution <- case solveOutcome of+        Sat -> do+            solution <- getSolution vars+            return $ Just solution+        Unsat -> return Nothing+        Unknown -> return Nothing+        --_ -> return $ error $ "error solving guard " ++ show guard ++ " [" ++ show vars ++ "]"+    pop+    return mSolution
+ src/Lattest/SMT.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+module Lattest.SMT (+  SMT,+  SolvableProblem(..),++  addAssertions,+  addDeclarations,+  getSolution,+  getSolvable,+  pop,+  push,+  runSMT+) where++import Data.SBV( constrain, HasKind(isBoolean), SBV, SymVal (..), freshVar)+import Data.SBV.Control( CheckSatResult, checkSat, getModel, query, Query)+import Data.SBV.Internals( CV(cvVal), CVal(..), SMTModel(modelAssocs),cvToBool )+import qualified Data.SBV as SBV+import qualified Data.SBV.Control as SBV+import qualified Data.SBV.List as SBV+import qualified Data.SBV.Internals as SBVI -- 'unsafe' internals++import Lattest.Model.Symbolic.Expr(ExprView(..), Variable (..), Valuation, Expr, fromConstantsMap, Type (..), Constant (..), toConstantsMap, view)+import Lattest.Model.Symbolic.Internal.FreeMonoidX+import Lattest.Model.Symbolic.Internal.Sum(SumTerm(..))++import Control.Monad((<=<))+import Control.Monad.State (StateT, evalStateT, lift, modify, gets)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Lattest.Model.Symbolic.Internal.Product (ProductTerm(..))++--------------------+-- exported types and functions+-- these define the interface to+-- the SMT backend+--------------------+type  Solution v       =  Map.Map v Constant+data  SolvableProblem  = Sat+                       | Unsat+                       | Unknown+     deriving (Eq,Ord,Read,Show)+data  SolveProblem v  = Solved (Solution v)+                      | Unsolvable+                      | UnableToSolve+     deriving (Eq,Ord,Read,Show)++type SMT = StateT (Map String SBVI.SVal) Query++runSMT :: SMT a -> IO a+runSMT = SBV.runSMT . query . flip evalStateT Map.empty++getSolution :: [Variable] -> SMT Valuation+getSolution vs =+  fromConstantsMap+  . (`Map.intersection` Map.fromList (map (,()) vs))+  . toConstantsMap+  . sbvModelToValuation <$> lift getModel++addAssertions :: [Expr Bool] -> SMT ()+addAssertions = mapM_ (lift . constrain <=< exprToSymbolic . view)++-- This is the reason we have the StateT wrapper in SMT:+-- SBV wants us to keep track of the symbolic variables+-- we get on each declaration, and use them to reference+-- the variable.+addDeclarations :: [Variable] -> SMT ()+addDeclarations = mapM_ $ \(Variable nm tp) -> case tp of+  IntType -> do+    SBVI.SBV v <- freshVar @Integer nm+    modify $ Map.insert nm v+  BoolType -> do+    SBVI.SBV v <- freshVar @Bool nm+    modify $ Map.insert nm v+  StringType -> do+    SBVI.SBV v <- freshVar @String nm+    modify $ Map.insert nm v+  FloatType -> do+    SBVI.SBV v <- freshVar @Double nm+    modify $ Map.insert nm v++getSolvable :: SMT SolvableProblem+getSolvable = checkSatToSolveProblem <$> lift checkSat++pop, push :: SMT ()+pop  = lift $ SBV.pop  1+push = lift $ SBV.push 1++---------------+-- Non-exported functions+---------------++-- The main translation between our Exprs and SBV's Symbolic+exprToSymbolic :: (Show a, SBV.SymVal a) => ExprView a -> SMT (SBV a)+exprToSymbolic v = case v of+  Var (Variable nm _tp) -> gets (SBVI.SBV . (Map.! nm))+  Const t -> pure $ literal t+  Ite i t e -> SBV.ite <$> go i <*> go t <*> go e+  EqualInt    l r -> (SBV..==) <$> go l <*> go r+  EqualFloat  l r -> (SBV..==) <$> go l <*> go r+  EqualString l r -> (SBV..==) <$> go l <*> go r+  EqualBool   l r -> (SBV..==) <$> go l <*> go r+  Divide      x y -> SBV.sDiv  <$> go x <*> go y+  DivideFloat x y -> (/)       <$> go x <*> go y+  Modulo x y      -> SBV.sMod  <$> go x <*> go y+  Sum      s -> foldOccur (\(SumTerm x) i symY -> (\sX sY -> sX * literal i               + sY) <$> go x <*> symY) (pure $ literal 0) s+  SumFloat s -> foldOccur (\(SumTerm x) i symY -> (\sX sY -> sX * literal (fromInteger i) + sY) <$> go x <*> symY) (pure $ literal 0) s+  Product      p -> foldOccur (\(ProductTerm x) i symY -> (\x' y -> x' ^ i * y) <$> go x <*> symY) (pure $ literal 1) p+  ProductFloat p -> foldOccur (\(ProductTerm x) i symY -> (\x' y -> x' ^ i * y) <$> go x <*> symY) (pure $ literal 1) p+  Length s -> SBV.length <$> go s+  GezInt   i -> (SBV..>= literal 0) <$> go i+  GezFloat f -> (SBV..>= literal 0) <$> go f+  Not b -> SBV.sNot <$> go b+  And xs -> foldr (\b bs -> (SBV..&&) <$> go b <*> bs) (pure $ literal True) (Set.toList xs)+   -- The below version errors because SBV doesn't properly declare some variable+   -- My best guess is that it's a bug if you use 'and' inside a Query, but I haven't+   -- looked deep enough nor done enough testing to report as a bug.+   -- SBV.and <$> foldr (\b bs -> (SBV..:) <$> go b <*> bs) (pure SBV.nil) (Set.toList xs)+  Concat strs -> SBV.concat <$> foldr (\s ss -> (SBV..:) <$> go s <*> ss) (pure SBV.nil) strs+  where+    go :: (SBV.SymVal a, Show a) => ExprView a -> SMT (SBV a)+    go = exprToSymbolic++checkSatToSolveProblem :: CheckSatResult -> SolvableProblem+checkSatToSolveProblem = \case+  SBV.Sat -> Sat+  SBV.Unsat -> Unsat+  SBV.Unk -> Unknown+  SBV.DSat _ -> Unknown++sbvModelToValuation :: SMTModel -> Valuation+sbvModelToValuation = fromConstantsMap . foldr f Map.empty . modelAssocs+  where+    f (varname, cv) = (\(typ, c) -> Map.insert (Variable varname typ) c) $ case cvVal cv of+      -- booleans for some reason are represented as CInteger with a different 'Kind'+      _ | isBoolean cv -> (BoolType, Cbool (cvToBool cv))+      CInteger i -> (IntType, Cint i)+      CString s -> (StringType, Cstring s)+      CDouble d -> (FloatType, Cfloat d)+      _ -> error "todo: the other SBV types, including lists, sets, arbitrary ADTs, floating point values, etc"+
+ src/Lattest/Streams/Synchronized.hs view
@@ -0,0 +1,255 @@+module Lattest.Streams.Synchronized (+TInputStream,+read,+readAll,+unRead,+hasInput,+fromInputStreamBuffered,+makeTInputStream,+fromBuffer,+fromTMVar,+duplicate,+map,+mapUnbuffered,+mergeBuffered,+mergeBufferedWith,+consumeBufferedWith,+Streamed(..),+tryRead,+tryReadIO,+tryReadIO'+)+where++import Prelude hiding (read, map)+import Control.Concurrent.STM(STM, retry)+import Control.Concurrent.STM.TQueue(TQueue, newTQueueIO, writeTQueue, readTQueue, isEmptyTQueue, unGetTQueue)+import Control.Concurrent.STM.TMVar(TMVar, takeTMVar, isEmptyTMVar)+import Control.Concurrent.STM.TVar(newTVarIO, readTVar, writeTVar)+import GHC.IO.Exception (ioe_location, ioe_errno)+import Control.Exception(throwIO, Exception, catchJust)+import Control.Monad (void, when)+import Data.List(singleton)++import GHC.Conc (atomically, forkIO)+import System.IO.Streams (InputStream, OutputStream, makeOutputStream, connect)+import qualified System.IO.Streams as Streams (write)+import Control.Monad.Extra((||^))+import Foreign.C.Error (eBADF, Errno (Errno))++data TInputStream a = TInputStream {+    tRead :: STM (Maybe a),+    tUnRead :: a -> STM (),+    tHasInput :: STM Bool -- whether this stream has a (Maybe a) available right now, *or* whether it is closed. Note: it may be tempting+                          -- to omit this field, and just check whether tRead retries, but that is ambiguous: tRead will retry either if+                          -- there is no input yet, *or* if someone is writing to the unknown TVars used to implement tRead. The first case+                          -- would not have an input, the second case would.+    }++read :: TInputStream a -> STM (Maybe a)+read = tRead++hasInput :: TInputStream a -> STM Bool+hasInput = tHasInput++-- read inputs from the stream until it has no more input+readAll :: TInputStream a -> STM [Maybe a]+readAll tis = reverse <$> readAll' []+    where+    readAll' acc = do+        readAttempt <- tryRead tis+        case readAttempt of+            StreamClosed -> return (Nothing:acc)+            Unavailable -> return acc+            Available next -> readAll' (Just next:acc)++unRead :: a -> TInputStream a -> STM ()+unRead = flip tUnRead++data Streamed a = Available a | Unavailable | StreamClosed deriving (Eq, Ord, Show, Read)++tryRead :: TInputStream a -> STM (Streamed a)+tryRead tis = do+    ready <- hasInput tis+    if ready+        then do+            minput <- read tis+            return $ maybe StreamClosed Available minput+        else return Unavailable++tryReadIO :: TInputStream a -> IO (Streamed a)+tryReadIO = atomically . tryRead++data TInputStreamClosedException = TInputStreamClosedException deriving (Eq, Ord, Show)+instance Exception TInputStreamClosedException++tryReadIO' :: TInputStream a -> IO (Maybe a)+tryReadIO' tis = do+    streamed <- tryReadIO tis+    case streamed of+        Available a -> return $ Just a+        Unavailable -> return Nothing+        StreamClosed -> throwIO TInputStreamClosedException++makeTInputStream :: STM (Maybe a) -> STM Bool -> IO (TInputStream a)+makeTInputStream readInput hasInput' = do+    pushbackStack <- newTQueueIO+    withClosedState $ TInputStream {+        tRead = do+            hasPushback <- isNonEmptyTQueue pushbackStack+            if hasPushback+                then Just <$> readTQueue pushbackStack+                else readInput,+        tUnRead = unGetTQueue pushbackStack,+        tHasInput = isNonEmptyTQueue pushbackStack ||^ hasInput'+        }++withClosedState :: TInputStream a -> IO (TInputStream a)+withClosedState stream = do+    closeVar <- newTVarIO False+    return $ TInputStream {+        tRead = do+            closed <- readTVar closeVar+            if closed+                then return Nothing+                else do+                    mi <- tRead stream+                    case mi of+                        Just i -> return $ Just i+                        Nothing -> do+                            writeTVar closeVar True+                            return Nothing,+        tUnRead = tUnRead stream,+        tHasInput = do+            closed <- readTVar closeVar+            if closed+                then return True+                else tHasInput stream+        }++fromTMVar :: TMVar (Maybe a) -> IO (TInputStream a)+fromTMVar tmvar = makeTInputStream (takeTMVar tmvar) (not <$> isEmptyTMVar tmvar)++-- note: the buffer is also used to push back values. Thus, do not read this buffer from outside the resulting stream, as then this stream may+-- violate the principle that pushed back values are read again.+fromBuffer :: TQueue (Maybe a) -> IO (TInputStream a)+fromBuffer buffer = withClosedState $ TInputStream {+        tRead = readTQueue buffer,+        tUnRead = unGetTQueue buffer . Just,+        tHasInput = isNonEmptyTQueue buffer+    }++-- a synchronized input stream that reads from the given input stream. A monitoring thread reads the given input stream and buffers the inputs on the background+-- TODO support a bound for the buffer+fromInputStreamBuffered :: InputStream a -> IO (TInputStream a)+fromInputStreamBuffered is = do+    buffer <- newTQueueIO+    bufferOS <- makeOutputStream $ atomically . writeTQueue buffer -- an intermediate output stream to write to the queue+    void $ forkIO $ catchSocketClosed $ connect is bufferOS -- move items from the original adapter into the buffer in a separate thread+    fromBuffer buffer+ where+   -- catches "threadWait: invalid argument (Bad file descriptor)"+   -- which is thrown when the socket is closed while this thread is running, e.g. on Adaptor.close()+   -- The alternative solution is to keep track of the threadID given by forkIO,+   -- and explicitly stop the thread before closing the socket.+   catchSocketClosed forkedThread = catchJust threadwaitinvalid forkedThread pure+   threadwaitinvalid e+    | ioe_location e == "threadWait"+    , fmap Errno (ioe_errno e) == Just eBADF = Just ()+    | otherwise = Nothing++mapUnbuffered :: (a -> b) -> (b -> a) -> TInputStream a -> TInputStream b -- we need an inverse to push a's back to the original TInputStream of b's+mapUnbuffered f f' tis = TInputStream { -- FIXME either remove or wrap in withClosedState+    tRead = fmap f <$> read tis,+    tUnRead = tUnRead tis . f',+    tHasInput = tHasInput tis+    }++map :: (a -> b) -> TInputStream a -> IO (TInputStream b) +map f tis = makeTInputStream (fmap f <$> read tis) (hasInput tis)++-- Take inputs from both given input streams. If both streams have an input available, the first stream takes precedence. The resulting stream closes +-- if either given stream closes. The merge is buffered, so that the sequence of arrival of inputs in both streams is preserved, even if the resulting+-- stream is not read.+mergeBuffered :: TInputStream a -> TInputStream a -> IO (TInputStream a)+mergeBuffered = mergeBufferedWith $ \tis1 tis2 -> singleton <$> do+    ready1 <- hasInput tis1+    if ready1+        then read tis1+        else do+            ready2 <- hasInput tis2+            if ready2+                then read tis2+                else retry++-- Take inputs from both given input streams, using the given combinator function. The merge is buffered, so that the sequence of arrival of inputs in both streams is preserved,+-- even if the resulting stream is not read. The resulting stream closes if either given stream closes.+mergeBufferedWith :: (TInputStream a -> TInputStream a -> STM [Maybe a]) -> TInputStream a -> TInputStream a -> IO (TInputStream a)+mergeBufferedWith merge tis1 tis2 = consumeBufferedWith (merge tis1 tis2) (hasAnyInput tis1 tis2) -- FIXME if one stream closes, then no further inputs should be read from the other stream, and only Nothings should be returned instead++hasAnyInput :: TInputStream a -> TInputStream a -> STM Bool+hasAnyInput tis1 tis2 = hasInput tis1 ||^ hasInput tis2++-- Actively take inputs from the given list STM, via a separate thread. This ensures that ordering from the given list STM is preserved as much as possible,+-- in case of concurrent inputs. The resulting stream only reads via the separate thread if needed, and reads from the list STM directly if this is faster.+-- The resulting stream closes if the consumer closes. This function assumes that the given STMs close properly, i.e., no Just's are sent after a Nothing+consumeBufferedWith :: STM [Maybe a] -> STM Bool -> IO (TInputStream a)+consumeBufferedWith producer producerHasInput = do+    buffer <- newTQueueIO+    let writeToBuffer = writeTQueue buffer+    --bufferOS <- makeOutputStream $ \x -> putStrLn "Synchronized.merging" >> (atomically . writeTQueue buffer) x -- an intermediate output stream to write to the queue+    void $ forkIO $ bufferLoop writeToBuffer -- move items from the original streams into the buffer in a separate thread+    bufferIS <- fromBuffer buffer+    return $ bufferIS {+        tRead = pickOneAndMergeRest buffer writeToBuffer,+        tHasInput = hasInput bufferIS ||^ producerHasInput+        }+    where+    bufferLoop writeToBuffer = do+        continue <- atomically $ do+            produced <- producer+            writeSeqTo produced writeToBuffer+        when continue $ bufferLoop writeToBuffer+    writeSeqTo [] _ = return True  -- TODO this is an OutputStream utils function, similar to Streams.write/writeTo, move to an appropriate module+    writeSeqTo (Nothing:_) writeToBuffer = do+        _ <- writeToBuffer Nothing+        return False+    writeSeqTo (Just a:as) writeToBuffer = do+        _ <- writeToBuffer (Just a)+        writeSeqTo as writeToBuffer+    pickOneAndMergeRest buffer writeToBuffer = do+        bufferHasInput <- not <$> isEmptyTQueue buffer+        produced <- if bufferHasInput+            then singleton <$> readTQueue buffer+            else producer+        case produced of+            [] -> retry+            (Just x:xs) -> do+                void $ writeSeqTo xs writeToBuffer+                return $ Just x+            (Nothing:_) -> do+                unGetTQueue buffer Nothing+                return Nothing++{-+-- TODO either remove or expose as nice util function, even though we don't seem to need this now+tconnect :: TInputStream a -> OutputStream a -> IO ()+tconnect tis os = tconnect'+    where+    tconnect' = do+        mA <- atomically $ read tis+        case mA of+            Nothing -> Streams.write Nothing os+            Just _ -> do+                Streams.write mA os+                tconnect'+-}++-- FIXME split to a separate module, conceptually there's nothing synchronized about this w.r.t. other OutputStreams+duplicate :: OutputStream a -> OutputStream a -> IO (OutputStream a)+duplicate out1 out2 = makeOutputStream $ \maybeVal -> do+    Streams.write maybeVal out1+    Streams.write maybeVal out2++isNonEmptyTQueue :: TQueue a -> STM Bool+isNonEmptyTQueue queue = not <$> isEmptyTQueue queue
+ src/Lattest/Streams/Synchronized/Attoparsec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}++module Lattest.Streams.Synchronized.Attoparsec (+parseFromStream,+parserToInputStream+)+where++import           Control.Exception(Exception)+import           Control.Monad(unless)+import           Data.String(IsString)+import           Control.Monad.Extra((||^), (&&^))+import qualified Data.Attoparsec.ByteString as C8(parse,feed, Parser)+import           Data.Attoparsec.Types(Parser,IResult(..))+import           Data.ByteString(ByteString)+import qualified Data.ByteString as C8(null)+import           Data.List(intercalate)++import           Lattest.Streams.Synchronized (TInputStream,makeTInputStream,hasInput)+import qualified Lattest.Streams.Synchronized as Streams (read, unRead)+import Control.Concurrent.STM.TVar(TVar, newTVarIO, writeTVar, readTVar)+import Control.Concurrent.STM(STM, throwSTM)++parseFromStream :: TVar (Bool, IResult ByteString (Maybe r)) -> Parser ByteString (Maybe r) -> TInputStream ByteString -> STM (Maybe r)+parseFromStream stateVar parser is = do+    parseFromStream' stateVar True is+    (closed, state) <- readTVar stateVar+    writeTVar stateVar (closed, C8.parse parser "")+    if closed+        then return Nothing+        else case state of+            (Done "" r) -> return r+            other ->+                let (residual,ctx,message) = errorContext other+                in throwSTM $ ParseException (toMsg ctx ++ message ++ ", residual [" ++ show residual ++ "]")+    where+    toMsg [] = ""+    toMsg xs = "[parsing " ++ intercalate "/" xs ++ "] "++parseFromStream' :: TVar (Bool, IResult ByteString (Maybe r)) -> Bool -> TInputStream ByteString -> STM ()+parseFromStream' stateVar blockUntilFinished is = do+    (closed, r) <- readTVar stateVar+    if closed+        then return ()+        else doParse r >>= writeTVar stateVar+    where+    doParse :: IResult ByteString (Maybe r) -> STM (Bool, IResult ByteString (Maybe r))+    doParse r = do+        stop <- return (isFinished r) ||^ (return (not blockUntilFinished) &&^ (not <$> hasInput is))+        if stop+            then do+                r' <- unread' r+                return (False, r')+            else  do+                m <- Streams.read is+                case m of+                    Nothing -> do+                        r' <- unread' r+                        return (True, r')+                    Just s -> if C8.null s+                        then doParse r+                        else doParse $! C8.feed r s+    unread rest = unless (C8.null rest) $ Streams.unRead rest is+    +    unread' (Fail rest ctx e) = unread rest >> return (Fail "" ctx e)+    unread' (Done rest result) = unread rest >> return (Done "" result)+    unread' partial = return partial++errorContext :: IsString a => IResult a r -> (a, [String], String)+errorContext (Fail residual ctx msg) = (residual, ctx, msg)+errorContext (Partial _) = ("", [], "")+errorContext (Done residual _) = (residual, [], "")++isFinished :: IResult a b -> Bool+isFinished (Partial _) = False+isFinished _ = True++newtype ParseException = ParseException String++instance Exception ParseException+instance Show ParseException where+    show (ParseException message) = "Parse error: " ++ message++-- Convert a stream of bytes to a stream of actions parsed from those bytes, using the provided parser. The stream ends if either the parser yields+-- a Nothing or if the underlying stream yields a Nothing+-- If the parser yields a Nothing, then all bytes up to that Nothing are consumed from the underlying stream, but if the underyling stream yields a+-- Nothing, then all bytes since the last Just result are unread.+parserToInputStream :: C8.Parser (Maybe r)+                    -> TInputStream ByteString+                    -> IO (TInputStream r)+parserToInputStream parser is = do+    stateVar <- newTVarIO (False, C8.parse parser "")+    makeTInputStream (parseFromStream stateVar parser is) (parserHasInput stateVar)+    where+    parserHasInput stateVar = do+        parseFromStream' stateVar False is+        (closed, state) <- readTVar stateVar+        return $ closed || isFinished state+++
+ src/Lattest/Util/IOUtils.hs view
@@ -0,0 +1,86 @@+{- |+    An unsorted collection of utility functions for working with the IO monad.+-}+module Lattest.Util.IOUtils (+-- * Control flow+ifM_,+ifMM_,+ifM,+ifMM,+whileM,+transformWhile,+doMaybe,+-- * STM Control flow+waitUntil,+doAfter,+-- * Encoding state in IO monads+statefulIO,+statefulIO'+)+where++import Control.Monad (void, unless, when)+import GHC.Conc(newTVarIO, readTVar, writeTVar, atomically, STM, retry)++-- | While-loop for monads. Any state passed between loop iterations should be carried by the monad.+whileM :: (Monad m) => m Bool -> m () -> m ()+whileM mb m = ifMM_ mb (m >> whileM mb m)++-- | If-statement for monads, with a monadic condition: if the condition holds, execute the given monad and discard the result, otherwise return ().+ifMM_ :: (Monad m) => m Bool -> m a -> m ()+ifMM_ mb m = do+    b <- mb+    ifM_ b m++-- | If-statement for monads, with a pure condition: if the condition holds, execute the given monad and discard the result, otherwise return ().+ifM_ :: (Applicative m) => Bool -> m a -> m ()+ifM_ b m = when b $ void m++-- | If-statement for monads, with a monadic condition: if the condition holds, execute the given monad and return the result, otherwise return Nothing.+ifMM :: (Monad m) => m Bool -> m a -> m (Maybe a)+ifMM mb m = do+    b <- mb+    ifM b m++-- | If-statement for monads, with a pure condition: if the condition holds, execute the given monad and return the result, otherwise return Nothing.+ifM :: Applicative m => Bool -> m a -> m (Maybe a)+ifM b m = if b then Just <$> m else pure Nothing++-- | Execute the given Monad, or return () if not present.+doMaybe :: Applicative m => Maybe (m ()) -> m ()+doMaybe (Just m) = m+doMaybe Nothing = pure ()++-- | While-loop for monads with explicit state passing.+transformWhile :: (Monad m) => a -> (a -> m (a, Bool)) -> m a+transformWhile state transformAndPredicate = do+    (state', condition) <- transformAndPredicate state+    if condition+        then transformWhile state' transformAndPredicate+        else return state'++-- | Produce an IO monad that behaves like the given Mealy machine, with separate transition and output functions.+statefulIO :: (q -> i -> q) -> (q -> i -> o) -> q -> IO (i -> IO o)+statefulIO transitionFunction outputFunction = statefulIO' (\q i -> (transitionFunction q i, outputFunction q i))++-- | Produce an IO monad that behaves like the given Mealy machine, with a combined transition/output function.+statefulIO' :: (q -> i -> (q, o)) -> q -> IO (i -> IO o)+statefulIO' transitionFunction initialState = do+    stateRef <- newTVarIO initialState+    return $ \i -> atomically $ do+        state <- readTVar stateRef+        let (state', output) = transitionFunction state i+        writeTVar stateRef state'+        return output++-- | An STM action that waits for the given STM condition+waitUntil :: STM Bool -> STM ()+waitUntil condition = do+    mayContinue <- condition+    unless mayContinue retry++-- | An STM action that waits for the given STM condition, and then performs the given STM action+doAfter :: STM Bool -> STM a -> STM a+doAfter condition action = do+    waitUntil condition+    action
+ src/Lattest/Util/ModelParsingUtils.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++module Lattest.Util.ModelParsingUtils (readAutFile, dumpLTSdot) where++import Lattest.Model.Alphabet(IOAct(..))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Set as Set+import Data.Maybe (mapMaybe)++import Data.List (isSuffixOf)+import Data.Containers.ListUtils (nubOrd)++{-|+    Read an .aut file representing an LTS from the provided filepath, parse its content and return:+    - [String]: Input Alphabet+    - [String]: Output Alphabet+    - Set.Set String: Set of all LTS states+    - String: Initial state+    - Maybe [(String, IOAct String String, String)]: List of LTS transition tuples as (InitialState, Action, EndState)+    NOTE: In order to parse actions correctly, inputs and outputs must end in _i and _o respectively. The first line of the .aut file must follow the structure des (initState,nEdges,nStates).+-}+readAutFile :: FilePath -> IO ([String], [String], Set.Set String, String, Maybe [(String, IOAct String String, String)])+readAutFile path = do+    contents <- TIO.readFile path+    let linesT = T.lines contents+    case linesT of+      [] -> error $ "Error: empty file: " <> path+      firstLine : restLines ->+        case parseInitialState firstLine of+          Nothing -> error "Error: Could not parse initial state from header."+          Just initialState ->+            let parsed = mapMaybe parseTupleLine restLines+                inputAlphabet  = nubOrd [s | (_, In s, _)  <- parsed]+                outputAlphabet = nubOrd [s | (_, Out s, _) <- parsed]+                allStates = Set.fromList $+                            [s1 | (s1, _, _) <- parsed] +++                            [s2 | (_, _, s2) <- parsed]+            in return (inputAlphabet, outputAlphabet, allStates, initialState, Just parsed)++-- | Parse initial line of .aut file and return initialState. The line must follow the structure des (initState,nEdges,nStates).+parseInitialState :: T.Text -> Maybe String+parseInitialState line =+  case T.stripPrefix "des (" (T.strip line) of+    Nothing -> Nothing+    Just rest ->+      let elems = T.split (==',') (T.replace ")," "" rest)+      in case elems of+           (s:_) -> Just (T.unpack (T.strip s))+           _     -> Nothing++-- | Parse a text line of the form (state, action, state), and return the transition tuple+-- | NOTE: only action labels finished in "_i" or "_o" are considered+parseTupleLine :: T.Text -> Maybe (String, IOAct String String, String)+parseTupleLine line =+    let stripped = T.strip line -- Remove trailing whitespaces+        removedParen = (T.replace ")" "" . T.replace "(" "" . T.replace ")," "") stripped+        transition = T.split (==',') removedParen+    in case transition of+        [s1, act, s2] ->+            let actionStr = T.unpack (T.strip act)+                initState = T.unpack (T.strip s1)+                endState = T.unpack (T.strip s2)+            in if "_i" `isSuffixOf` actionStr then+                   Just (initState, In actionStr, endState)+               else if "_o" `isSuffixOf` actionStr then+                   Just (initState, Out actionStr, endState)+               else+                   Nothing -- Non-valid action+        _ -> Nothing  -- Malformed line++-- | Build a .dot file representation of LTS transitions and save it in the specified File Path+dumpLTSdot :: (Show s, Show i, Show o) => FilePath -> [(s, IOAct i o, s)] -> IO ()+dumpLTSdot path transitions = do+    let edges = [ (show from, T.unpack (T.replace "!" "" . T.replace "?" "" $ T.pack (show label)), show to)+                | (from, label, to) <- transitions ]+    let dotPath = if ".dot" `isSuffixOf` path then path else path ++ ".dot"+    writeFile dotPath $+        unlines $+            ["digraph Automaton {"] +++            [ "    " ++ from ++ " -> " ++ to ++ " [label=" ++ label ++ "];" +            | (from, label, to) <- edges+            ] ++ ["}"]+    putStrLn $ "DOT file written to: " ++ dotPath
+ src/Lattest/Util/ReportUtils.hs view
@@ -0,0 +1,67 @@+module Lattest.Util.ReportUtils+    ( writeResults+    , flushResults+    , initResultsFile+    , TestResult(..)+    ) where++import Data.Csv (ToRecord(..), record, toField, encode)+import Data.Maybe (fromMaybe)+import Data.Foldable (toList)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Sequence as Seq+import Control.Monad (void)+++data TestResult = TestResult+    { testNumber :: Int+    , verdict    :: String+    , trace      :: String+    }++defaultHeader :: (String, String, String)+defaultHeader = ("test_number", "verdict", "trace")++{-|+    Initialize a CSV file for test results with an optional header. If no header is+    provided, a default one will be used.+-}+initResultsFile :: FilePath -> Maybe (String, String, String) -> IO ()+initResultsFile csvPath mHeader =+    BS.writeFile csvPath (BL.toStrict (encode [fromMaybe defaultHeader mHeader]))++instance ToRecord TestResult where+    toRecord (TestResult n v t) = record [toField n, toField v, toField t]++{-| +    Append a list of 'TestResult' rows to a CSV file, with optional buffering given by 'threshold'.+     - If 'threshold' is 0, results are written immediately.+     - If 'threshold' > 0, results are buffered until the buffer length reaches the threshold, at which+     point they are written to the file.+    Returns the updated (reverseBuffer, bufferLength) pair.+    Note: this function assumes the CSV file already exists.+-}+writeResults+    :: FilePath+    -> [TestResult]+    -> Seq.Seq TestResult+    -> Int+    -> IO (Seq.Seq TestResult)+writeResults csvPath newResults buf threshold = do+    let newBuf    = buf Seq.>< Seq.fromList newResults+        newBufLen = Seq.length newBuf+    if threshold == 0 || newBufLen >= threshold+        then do+            BS.appendFile csvPath (BL.toStrict (encode (toList newBuf)))+            return Seq.empty+        else+            return newBuf++{-| +    Flush remaining 'TestResult' rows to a CSV file.+    Note: this function assumes the CSV file already exists.+-}+flushResults :: FilePath -> Seq.Seq TestResult -> IO ()+flushResults csvPath revBuf =+    void $ writeResults csvPath [] revBuf 0
+ src/Lattest/Util/STSJSONParser.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}++module Lattest.Util.STSJSONParser (+    stsFromJSONFile,+) where++import Control.Monad (forM)+import qualified Data.Aeson as JSON+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map.Strict as Map+import Data.Scientific (floatingOrInteger, toRealFloat, Scientific)+import qualified Data.Set as Set+import Data.Text (unpack)+import Data.Maybe (fromMaybe)+import Lattest.Model.Alphabet (IOAct (..), SymInteract (..))+import Lattest.Model.Automaton (stsTLoc, STStdest)+import Lattest.Model.BoundedMonad (FreeLattice, atom, (/\))+import Lattest.Model.StandardAutomata (IOSTS, automaton)+import Lattest.Model.Symbolic.Expr ((=:), (./), (.%), (.+), (.-), (.*), (.==), (.>=), (.<=), (.<), (.>), (.||), (.&&), sNeg, sNot, assignment, sTrue, sConcat, sConst, sVar, Expr, ExprNum, Type (..), Variable (..), Valuation, VarModel, Constant (..), insertIntoValuation, assignValues)++data UntypedExpr+    = UEBool Bool+    | UENumber Scientific+    | UEStr  String+    | UEOp1  String UntypedExpr+    | UEOp2  String UntypedExpr UntypedExpr+    deriving (Show, Eq)++instance JSON.FromJSON UntypedExpr where+    parseJSON (JSON.Bool b)   = pure (UEBool b)+    parseJSON (JSON.Number n) = pure (UENumber n)+    parseJSON (JSON.String s) = pure (UEStr (unpack s))+    parseJSON (JSON.Object o) = do+        (op :: String) <- o JSON..: "op"+        case op of+            "neg" -> UEOp1 op <$> o JSON..: "rhs"+            "not" -> UEOp1 op <$> o JSON..: "rhs"+            _     -> UEOp2 op <$> o JSON..: "lhs" <*> o JSON..: "rhs"+    parseJSON _ = fail "expected expression"++type VarMap = Map.Map String Variable++lookupVar :: VarMap -> String -> Type -> (Variable -> Expr a) -> Either String (Expr a)+lookupVar varmap name expected mk = case Map.lookup name varmap of+    Just v@(Variable _ t) | t == expected -> Right (mk v)+    Just (Variable _ t) -> Left $ "variable '" ++ name ++ "' has type " ++ show t ++ ", expected " ++ show expected+    Nothing             -> Left $ "unknown variable: " ++ name++-- Used for equality and ordering comparisons, where the result is defined based on the type of lhs and rhs.+-- A variable's declared type always takes priority over a literal's type+inferOperandType :: VarMap -> UntypedExpr -> UntypedExpr -> Either String Type+inferOperandType varmap lhs rhs =+    case (varOperandType lhs, varOperandType rhs) of+        (Just t, _) -> Right t+        (_, Just t) -> Right t+        _ -> case (literalOperandType lhs, literalOperandType rhs) of+            (Just t, _) -> Right t+            (_, Just t) -> Right t+            _           -> Left "cannot determine operand type for operator"+    where+        varOperandType (UEStr name) = fmap varType (Map.lookup name varmap)+        varOperandType _            = Nothing+        literalOperandType (UEBool _)  = Just BoolType+        literalOperandType (UENumber n)+          | Left _ <- floatingOrInteger @Double @Integer n = Just FloatType+        literalOperandType _           = Nothing++toBoolExpr :: VarMap -> UntypedExpr -> Either String (Expr Bool)+toBoolExpr _   (UEBool b)          = Right (sConst b)+toBoolExpr varmap (UEStr name)        = lookupVar varmap name BoolType sVar+toBoolExpr varmap (UEOp1 "not" e)    = sNot  <$> toBoolExpr varmap e+toBoolExpr varmap (UEOp2 "&&" e1 e2) = (.&&) <$> toBoolExpr varmap e1 <*> toBoolExpr varmap e2+toBoolExpr varmap (UEOp2 "||" e1 e2) = (.||) <$> toBoolExpr varmap e1 <*> toBoolExpr varmap e2+toBoolExpr varmap (UEOp2 "==" e1 e2) = do+    t <- inferOperandType varmap e1 e2+    case t of+        IntType    -> (.==) <$> toIntExpr   varmap e1 <*> toIntExpr   varmap e2+        BoolType   -> (.==) <$> toBoolExpr  varmap e1 <*> toBoolExpr  varmap e2+        StringType -> (.==) <$> toStrExpr   varmap e1 <*> toStrExpr   varmap e2+        FloatType  -> (.==) <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+toBoolExpr varmap (UEOp2 "!=" e1 e2) = sNot <$> toBoolExpr varmap (UEOp2 "==" e1 e2)+toBoolExpr varmap (UEOp2 "<"  e1 e2) = toComparisonExpr (.<)  varmap e1 e2+toBoolExpr varmap (UEOp2 "<=" e1 e2) = toComparisonExpr (.<=) varmap e1 e2+toBoolExpr varmap (UEOp2 ">"  e1 e2) = toComparisonExpr (.>)  varmap e1 e2+toBoolExpr varmap (UEOp2 ">=" e1 e2) = toComparisonExpr (.>=) varmap e1 e2+toBoolExpr _   e                   = Left $ "not a boolean expression: " ++ show e++-- Numeric ordering comparisons are defined for both Integer and Float operands, but never mixed.+toComparisonExpr :: (forall t. ExprNum t => Expr t -> Expr t -> Expr Bool) -> VarMap -> UntypedExpr -> UntypedExpr -> Either String (Expr Bool)+toComparisonExpr cmp varmap e1 e2 = do+    t <- inferOperandType varmap e1 e2+    case t of+        IntType   -> cmp <$> toIntExpr   varmap e1 <*> toIntExpr   varmap e2+        FloatType -> cmp <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+        _         -> Left $ "comparison operator is not defined for type " ++ show t++toIntExpr :: VarMap -> UntypedExpr -> Either String (Expr Integer)+toIntExpr _   (UENumber n)+ | Right i <- floatingOrInteger @Double n = Right (sConst i)+toIntExpr varmap (UEStr name)         = lookupVar varmap name IntType sVar+toIntExpr varmap (UEOp1 "neg" e)     = sNeg <$> toIntExpr varmap e+toIntExpr varmap (UEOp2 "+"  e1 e2)  = (.+) <$> toIntExpr varmap e1 <*> toIntExpr varmap e2+toIntExpr varmap (UEOp2 "-"  e1 e2)  = (.-) <$> toIntExpr varmap e1 <*> toIntExpr varmap e2+toIntExpr varmap (UEOp2 "*"  e1 e2)  = (.*) <$> toIntExpr varmap e1 <*> toIntExpr varmap e2+toIntExpr varmap (UEOp2 "/"  e1 e2)  = (./) <$> toIntExpr varmap e1 <*> toIntExpr varmap e2+toIntExpr varmap (UEOp2 "%"  e1 e2)  = (.%) <$> toIntExpr varmap e1 <*> toIntExpr varmap e2+toIntExpr _   e                    = Left $ "not an integer expression: " ++ show e++toFloatExpr :: VarMap -> UntypedExpr -> Either String (Expr Double)+toFloatExpr _   (UENumber n)          = Right (sConst $ toRealFloat n)+toFloatExpr varmap (UEStr name)         = lookupVar varmap name FloatType sVar+toFloatExpr varmap (UEOp1 "neg" e)     = sNeg <$> toFloatExpr varmap e+toFloatExpr varmap (UEOp2 "+"  e1 e2)  = (.+) <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+toFloatExpr varmap (UEOp2 "-"  e1 e2)  = (.-) <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+toFloatExpr varmap (UEOp2 "*"  e1 e2)  = (.*) <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+toFloatExpr varmap (UEOp2 "/"  e1 e2)  = (./) <$> toFloatExpr varmap e1 <*> toFloatExpr varmap e2+toFloatExpr _   e                    = Left $ "not a real expression: " ++ show e++-- unknown strings are treated as string literals.+toStrExpr :: VarMap -> UntypedExpr -> Either String (Expr String)+toStrExpr varmap (UEStr name) =+    case Map.lookup name varmap of+        Just v@(Variable _ StringType) -> Right (sVar v)+        Just (Variable _ t) -> Left $ "variable '" ++ name ++ "' has type " ++ show t ++ ", expected String"+        Nothing             -> Right (sConst name)+toStrExpr varmap (UEOp2 "++" e1 e2)  = (\a b -> sConcat [a, b]) <$> toStrExpr varmap e1 <*> toStrExpr varmap e2+toStrExpr _   e                    = Left $ "not a string expression: " ++ show e++-- Location IDs can be integers or strings in JSON; both are mapped to String for consistency.+newtype LocationId = LocationId { locId :: String }++instance JSON.FromJSON LocationId where+    parseJSON v = case v of+        JSON.String s -> pure $ LocationId (unpack s)+        JSON.Number n -> pure $ LocationId (show (round n :: Integer))+        _             -> fail $ "expected string or number for LocationId, got: " ++ show v++newtype GateId = GateId { unGateId :: String }++-- Gate IDs can be integers or strings in JSON; both are mapped to String for consistency.+instance JSON.FromJSON GateId where+    parseJSON v = case v of+        JSON.String s -> pure $ GateId (unpack s)+        JSON.Number n -> pure $ GateId (show (round n :: Integer))+        _             -> fail $ "expected string or number for GateId, got: " ++ show v++newtype VarDefJson = VarDefJson { varDefJsonType :: String }++instance JSON.FromJSON VarDefJson where+    parseJSON = JSON.withObject "VarDefJson" $ \o ->+        VarDefJson <$> o JSON..: "type"++data GateDefJson = GateDefJson +    { gateDefJsonShortname :: Maybe String+    , gateDefJsonParams :: [String]+    }++instance JSON.FromJSON GateDefJson where+    parseJSON = JSON.withObject "GateDefJson" $ \o ->+        GateDefJson <$> o JSON..:? "shortname"+                    <*> o JSON..:  "parameters"++data AssignmentDefJson = AssignmentDefJson+    { assignmentJsonVar  :: String+    , assignmentJsonExpr :: UntypedExpr+    }++instance JSON.FromJSON AssignmentDefJson where+    parseJSON = JSON.withObject "AssignmentDefJson" $ \o ->+        AssignmentDefJson <$> o JSON..: "target" <*> o JSON..: "expression"++data SwitchDefJson = SwitchDefJson+    { switchJsonInitLoc     :: LocationId+    , switchJsonGate        :: GateId+    , switchJsonGuard       :: Maybe String+    , switchJsonAssignments :: [String]+    , switchJsonEndLoc      :: LocationId+    }++instance JSON.FromJSON SwitchDefJson where+    parseJSON = JSON.withObject "SwitchDefJson" $ \o ->+        SwitchDefJson+            <$> o JSON..:  "init_loc"+            <*> o JSON..:  "gate"+            <*> o JSON..:? "guard"+            <*> (o JSON..:? "assignments" JSON..!= [])+            <*> o JSON..:  "end_loc"++data STSJsonFormat = STSJsonFormat+    { stsJsonInitLoc       :: LocationId+    , stsJsonLocVars       :: Map.Map String VarDefJson+    , stsJsonParams        :: Map.Map String VarDefJson+    , stsJsonInitValuation :: Map.Map String JSON.Value+    , stsJsonLocations     :: [LocationId]+    , stsJsonInputGates    :: Map.Map String GateDefJson+    , stsJsonOutputGates   :: Map.Map String GateDefJson+    , stsJsonGuards        :: Map.Map String UntypedExpr+    , stsJsonAssignments   :: Map.Map String AssignmentDefJson+    , stsJsonSwitches      :: Map.Map String SwitchDefJson+    }++instance JSON.FromJSON STSJsonFormat where+    parseJSON = JSON.withObject "STSJsonFormat" $ \o ->+        STSJsonFormat+            <$> o JSON..:  "initial_location"+            <*> o JSON..:  "locationVariables"+            <*> o JSON..:  "parameters"+            <*> (o JSON..:? "initialValuation" JSON..!= Map.empty)+            <*> o JSON..:  "locations"+            <*> o JSON..:  "inputGates"+            <*> o JSON..:  "outputGates"+            <*> o JSON..:  "guards"+            <*> (o JSON..:? "assignments" JSON..!= Map.empty)+            <*> o JSON..:  "switches"++-- STS elements builders++parseVarType :: String -> Either String Type+parseVarType "integer" = Right IntType+parseVarType "int"     = Right IntType+parseVarType "float"   = Right FloatType+parseVarType "bool"    = Right BoolType+parseVarType "boolean" = Right BoolType+parseVarType "string"  = Right StringType+parseVarType t         = Left $ "unknown variable type: " ++ t++buildVarMap :: Map.Map String VarDefJson -> Either String (Map.Map String Variable)+buildVarMap defs = Map.fromList <$> forM (Map.toList defs) (\(name, def) -> do+    t <- parseVarType (varDefJsonType def)+    return (name, Variable name t))++buildGateMap+    :: (String -> IOAct String String)+    -> Map.Map String Variable+    -> Map.Map String GateDefJson+    -> Either String (Map.Map String (SymInteract (IOAct String String)))+buildGateMap mkGate varMap defs = Map.fromList <$> forM (Map.toList defs) (\(name, def) -> do+    let gateName = fromMaybe name (gateDefJsonShortname def)+    params <- forM (gateDefJsonParams def) $ \pname ->+        case Map.lookup pname varMap of+            Just v  -> Right v+            Nothing -> Left $ "unknown parameter '" ++ pname ++ "' in gate '" ++ name ++ "'"+    return (name, SymInteract (mkGate gateName) params))++buildAssignment+    :: VarMap+    -> String+    -> AssignmentDefJson+    -> Either String (VarModel -> VarModel)+buildAssignment varMap name def = do+    var <- case Map.lookup (assignmentJsonVar def) varMap of+        Just v  -> Right v+        Nothing -> Left $ "unknown variable '" ++ assignmentJsonVar def ++ "' in assignment '" ++ name ++ "'"+    let expr = assignmentJsonExpr def+    case varType var of+        IntType    -> (var =:) <$> toIntExpr   varMap expr+        BoolType   -> (var =:) <$> toBoolExpr  varMap expr+        StringType -> (var =:) <$> toStrExpr   varMap expr+        FloatType  -> (var =:) <$> toFloatExpr varMap expr++buildAssignmentMap+    :: VarMap+    -> Map.Map String AssignmentDefJson+    -> Either String (Map.Map String (VarModel -> VarModel))+buildAssignmentMap varMap defs =+    Map.fromList <$> forM (Map.toList defs) (\(name, def) ->+        (name,) <$> buildAssignment varMap name def)++buildVarModel+    :: Map.Map String (VarModel -> VarModel)+    -> [String]+    -> String+    -> Either String VarModel+buildVarModel assignMap names switchName = do+    updates <- forM names $ \aname ->+        case Map.lookup aname assignMap of+            Just f  -> Right f+            Nothing -> Left $ "unknown assignment '" ++ aname ++ "' in switch '" ++ switchName ++ "'"+    return (assignment updates)++buildSwitchList+    :: Map.Map String (SymInteract (IOAct String String))+    -> Map.Map String (Expr Bool)+    -> Map.Map String (VarModel -> VarModel)+    -> Map.Map String SwitchDefJson+    -> Either String [(String, SymInteract (IOAct String String), Expr Bool, VarModel, String)]+buildSwitchList gateMap guardMap assignMap switchDefs =+    forM (Map.toList switchDefs) $ \(name, def) -> do+        gate <- case Map.lookup (unGateId (switchJsonGate def)) gateMap of+            Just a  -> Right a+            Nothing -> Left $ "unknown gate '" ++ unGateId (switchJsonGate def) ++ "' in switch '" ++ name ++ "'"+        guard' <- case switchJsonGuard def of+            Nothing    -> Right sTrue+            Just gname -> case Map.lookup gname guardMap of+                Just g  -> Right g+                Nothing -> Left $ "unknown guard '" ++ gname ++ "' in switch '" ++ name ++ "'"+        varModel <- buildVarModel assignMap (switchJsonAssignments def) name+        let initLoc = locId (switchJsonInitLoc def)+            endLoc  = locId (switchJsonEndLoc  def)+        return (initLoc, gate, guard', varModel, endLoc)++-- NOTE: transitions from the same location with matching gates are combined with /\+buildTransitionRel+    :: [(String, SymInteract (IOAct String String), Expr Bool, VarModel, String)]+    -> String+    -> Map.Map (SymInteract (IOAct String String)) (FreeLattice (STStdest, String))+buildTransitionRel switchList loc =+    Map.fromListWith (/\)+        [ (gate, atom (stsTLoc guard' varModel, endLoc))+        | (initLoc, gate, guard', varModel, endLoc) <- switchList+        , initLoc == loc+        ]++buildValuation :: Map.Map String Variable -> Map.Map String JSON.Value -> Either String Valuation+buildValuation locVarCtx initVal =+    fmap (assignValues . map snd) $ forM (Map.toList locVarCtx) $ \(name, var) ->+        case (varType var, Map.lookup name initVal) of+            (IntType,    Just (JSON.Number n)) -> Right (name, insertIntoValuation var (Cint (round n)))+            (BoolType,   Just (JSON.Bool b))   -> Right (name, insertIntoValuation var (Cbool b))+            (StringType, Just (JSON.String s)) -> Right (name, insertIntoValuation var (Cstring (unpack s)))+            (FloatType,  Just (JSON.Number n)) -> Right (name, insertIntoValuation var (Cfloat (toRealFloat n)))+            (t, Just _)  -> Left $ "wrong type for initial value of '" ++ name ++ "', expected " ++ show t+            (_, Nothing) -> Right (name, insertIntoValuation var (defaultConst (varType var)))+    where+        -- TODO: for now give a default valuation if not present in the json, we can leave it blank and define+        -- this by test in the future+        defaultConst IntType    = Cint 0+        defaultConst BoolType   = Cbool False+        defaultConst StringType = Cstring ""+        defaultConst FloatType  = Cfloat 0.0++convertSTSJson :: STSJsonFormat -> Either String (IOSTS FreeLattice String String String, Valuation)+convertSTSJson json = do+    locVarMap <- buildVarMap (stsJsonLocVars json)+    paramMap  <- buildVarMap (stsJsonParams json)+    initVal    <- buildValuation locVarMap (stsJsonInitValuation json)+    let varMap = locVarMap `Map.union` paramMap+    inputGateMap  <- buildGateMap In  varMap (stsJsonInputGates json)+    outputGateMap <- buildGateMap Out varMap (stsJsonOutputGates json)+    let gateMap = inputGateMap `Map.union` outputGateMap+        alphabet  = Set.fromList (Map.elems gateMap)+    guardMap  <- traverse (toBoolExpr varMap) (stsJsonGuards json)+    assignMap <- buildAssignmentMap varMap (stsJsonAssignments json)+    switchList <- buildSwitchList gateMap guardMap assignMap (stsJsonSwitches json)+    let transRel = buildTransitionRel switchList+        initCfg  = atom $ locId (stsJsonInitLoc json)+        sts      = automaton initCfg alphabet transRel+    return (sts, initVal)++{-| +    Read a JSON file and parse an STS from it.+-}+stsFromJSONFile :: FilePath -> IO (Either String (IOSTS FreeLattice String String String, Valuation))+stsFromJSONFile path = do+    bytes <- BSL.readFile path+    return $ case JSON.eitherDecode bytes of+        Left  err     -> Left $ "JSON decode error: " ++ err+        Right stsJson -> convertSTSJson stsJson
+ src/Lattest/Util/Utils.hs view
@@ -0,0 +1,72 @@+{- |+    An unsorted collection of utility functions.+-}++module Lattest.Util.Utils (+-- * Boolean operators+(|||),+(&&&),+(||^^),+(&&^^),+-- * Random functions+flipCoin,+takeRandom,+-- * Maybe+distributeFirstMaybe,+-- * Set+takeArbitrary+)+where++import qualified Data.Set as Set+import Data.Set (Set)+import System.Random(RandomGen, uniformR)+import Control.Monad.Extra((||^), (&&^))++-- | Conjunction lifted to functions.+(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(&&&) pred1 pred2 b = pred1 b && pred2 b+infixr 3 &&&++-- | Disjunction lifted to functions.+(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(|||) pred1 pred2 b = pred1 b || pred2 b+infixr 2 |||++-- | Conjunction lifted to a doubly nested monad.+(&&^^) :: (Monad m1, Monad m2) => m1 (m2 Bool) -> m1 (m2 Bool) -> m1 (m2 Bool)+(&&^^) mmb1 mmb2 = do+    mb1 <- mmb1+    mb2 <- mmb2+    return $ mb1 &&^ mb2+infixr 3 &&^^++-- | Disjunction lifted to a doubly nested monad.+(||^^) :: (Monad m1, Monad m2) => m1 (m2 Bool) -> m1 (m2 Bool) -> m1 (m2 Bool)+(||^^) mmb1 mmb2 = do+    mb1 <- mmb1+    mb2 <- mmb2+    return $ mb1 ||^ mb2+infixr 3 ||^^++-- | Flip a coin for which the chance of result 'True' is p, where p is clamped to [0,1].+flipCoin :: RandomGen g => g -> Double -> (Bool, g)+flipCoin g p = let (f, g') = uniformR (0.0, 1.0) g in (f < p, g')++-- | Take a random element from the list. Gives an error for the empty list, so the user should check that first.+takeRandom :: RandomGen g => g -> [a] -> (a, g)+takeRandom g list+    | null list = error "takeRandom from empty list"+    | otherwise = let (i, g') = uniformR (0, length list - 1) g in (list !! i, g')++-- | If the first tuple element is a Nothing, then take a Nothing, ignoring the second element, otherwise take a Just of both elements.+distributeFirstMaybe :: (Maybe a, b) -> Maybe (a, b)+distributeFirstMaybe (Just a, b) = Just (a, b)+distributeFirstMaybe (Nothing, _) = Nothing++-- | Remove an arbitrary element from the given set, and return both that element and the remaining set, or `Nothing` if the given set was empty.+takeArbitrary :: Set a -> Maybe (a, Set a)+takeArbitrary set+    | Set.null set = Nothing+    | otherwise = Just (Set.elemAt 0 set, Set.deleteAt 0 set)+
+ test/Reference/FreeLatticeSlow.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+module Reference.FreeLatticeSlow (+FreeLatticeSlow,+)++where++import qualified Lattest.Model.Symbolic.Expr as E+++import Algebra.Lattice.Free (Free(..), lowerFree)+import Algebra.Lattice.Levitated(Levitated(..))+import Algebra.Lattice(Lattice)+import qualified Algebra.Lattice as L ((/\), (\/))+import Control.Monad(ap)+import Lattest.Model.BoundedMonad (BoundedConfiguration (..), JoinSemiLattice (..), MeetSemiLattice (..), BooleanConfiguration (..))+++{-|+    Free distributive lattice, or a positive boolean formula, i.e., a boolean formula with conjunctions and disjunctions over atomic propositions. The two elements 'top' and 'bot' can be interpreted as true and false.+    Behaviourally, this is equivalent to `FreeLattice`, but the size is not bounded by the normal form.+    This makes it less efficient when repeatedly applying operators, especially 'fmap' and monadic bind '>>='.+-}+newtype FreeLatticeSlow a = FreeLatticeSlow (Levitated (Free a)) deriving (Eq, Functor, Foldable, Lattice)++deriving instance Ord a => Ord (FreeLatticeSlow a)+deriving instance Ord a => Ord (Free a)++{-+-- Conjunction and disjunction on free distributive lattices.+-- note: this is already imlpemented by the JoinSemiLattice instance+(\/) :: FreeLatticeSlow a -> FreeLatticeSlow a -> FreeLatticeSlow a+(\/) = (L.\/)++-- | Conjunction on free distributive lattices.+(/\) :: FreeLatticeSlow a -> FreeLatticeSlow a -> FreeLatticeSlow a+(/\) = (L./\)+-}++{-|+    An FreeLatticeSlow as a state configuration means an automaton is in a state configuration of disjunctions (non-determinism) and conjunctions over states,+    where state configurations top and bottom, or true and false, indicate underspecified and forbidden configurations, respectively.+-}+instance BoundedConfiguration FreeLatticeSlow where+    isForbidden (FreeLatticeSlow Bottom) = True+    isForbidden _ = False+    isUnderspecified (FreeLatticeSlow Top) = True+    isUnderspecified _ = False+    forbidden = FreeLatticeSlow Bottom+    underspecified = FreeLatticeSlow Top++instance Applicative FreeLatticeSlow where+    pure = FreeLatticeSlow . Levitate . Var+    (<*>) = ap++instance Monad FreeLatticeSlow where+    (FreeLatticeSlow Bottom) >>= _ = FreeLatticeSlow Bottom+    (FreeLatticeSlow Top) >>= _ = FreeLatticeSlow Top+    (FreeLatticeSlow (Levitate x)) >>= f = lowerFree f x++instance Show a => Show (FreeLatticeSlow a) where+    show (FreeLatticeSlow Top) = "⊤"+    show (FreeLatticeSlow Bottom) = "⊥"+    show (FreeLatticeSlow (Levitate a)) = show' a+        where+        show' (Var a') = show a'+        show' (x :\/: y) = "(" ++ show' x ++ " ∨ " ++ show' y ++ ")"+        show' (x :/\: y) = "(" ++ show' x ++ " ∧ " ++ show' y ++ ")"++instance JoinSemiLattice (FreeLatticeSlow a) where+    (\/) = (L.\/) -- it should be possible to generalize this to arbitrary instances, see remark below the JoinSemiLattice class itself++instance MeetSemiLattice (FreeLatticeSlow a) where+    (/\) = (L./\) -- it should be possible to generalize this to arbitrary instances, see remark below the JoinSemiLattice class itself++instance BooleanConfiguration FreeLatticeSlow where+    asExpr (FreeLatticeSlow Top) = E.sTrue+    asExpr (FreeLatticeSlow Bottom) = E.sFalse+    asExpr (FreeLatticeSlow (Levitate a)) = asExpr' a+        where+        asExpr' (Var a') = a'+        asExpr' (x :\/: y) = asExpr' x E..|| asExpr' y+        asExpr' (x :/\: y) = asExpr' x E..&& asExpr' y++instance Traversable FreeLatticeSlow where+  sequenceA (FreeLatticeSlow Bottom)       = pure $ FreeLatticeSlow Bottom+  sequenceA (FreeLatticeSlow Top)          = pure $ FreeLatticeSlow Top+  sequenceA (FreeLatticeSlow (Levitate a)) = FreeLatticeSlow . Levitate <$> sequenceA a+
+ test/Test.hs view
@@ -0,0 +1,120 @@+import Test.Lattest.Adapter.StandardAdapters+import Test.Lattest.Exec.StandardTestControllers+import Test.Lattest.Exec.NComplete+import Test.Lattest.Exec.Testing+import Test.Lattest.Model.BoundedMonad+import Test.Lattest.Model.StandardAutomata+import Test.Lattest.Model.STSTest+import Test.Lattest.Model.Symbolic.Expr+import Test.Lattest.Util.ModelParsingUtils+import Test.Lattest.Util.STSJSONParserTest+import qualified Lattest.SMT as SMT+import Test.System.IO.Streams.Synchronized(prop_consumeBufferedWith, testConsumeBufferedWith,testConsumeBufferedWith_short, prop_jsonStream)+import qualified Data.Maybe as M++import Test.Tasty+import Test.Tasty.Runners as Tasty+import Test.Tasty.Providers as Tasty+import Test.HUnit as HUnit+import Test.Tasty.QuickCheck++durationSeconds :: Int+durationSeconds = 3++main :: IO ()+main = do+    hunitTests <- makeHUnitTests+    defaultMain $ +      localOption (NumThreads 1) $ -- some of these tests open concrete sockets, and thus can't be run multiple times in parallel+      testGroup "Lattest-tests"+        [ hunitTests+        , quickCheckTests+        ]++quickCheckTests :: TestTree+quickCheckTests = testGroup "Quickcheck"+  [ quickCheckWithTimeout (prop_jsonStream :: [(Int,Bool,Bool)] -> Property) "jsonStream"+--  Disable symbolic expression tests for now as they are too flaky+--    quickCheckWithTimeoutWithNum (prop_evalSymbolic :: PropEvalSymbolic Bool) 10000+--    quickCheckWithTimeoutWithNumWithSize prop_solveSymbolic 100 2+  , quickCheckWithTimeoutWithNum prop_consumeBufferedWith 15 "consumeBufferedWith"+  , quickCheckWithTimeoutWithNum (prop_latticeIsCNF :: LatticeOp Int -> Bool) 10000 "latticeIsCNF"+  ]++    where+    quickCheckWithTimeout prop = quickCheckWithTimeoutWithNum prop 100+    quickCheckWithTimeoutWithNum prop n name = testProperty name $ \testparam -> +      within (durationSeconds * 1000000) $ withMaxSize 20 $+      -- Shrinking interacts really badly with the timeout: QuickCheck ends up on a search for the smallest input that exceeds the timelimit.+      noShrinking $ prop testparam+++makeHUnitTests :: IO TestTree+makeHUnitTests = do+    return $+      localOption (NumThreads 1) $ -- some of these tests open concrete sockets, and thus can't be run in parallel+      singleTest "unit tests" $+      TestList $+        [+        testAccSeq,+        testADG,+        testConsumeBufferedWith,+        testConsumeBufferedWith_short,+        testJSONSocketAdapterByte,+        testAdapterAcceptingInput,+        testJSONSocketAdapterInt,+        testJSONSocketAdapterObject,+        testQuiscence,+        testInputDelay,+        testTraceHappy,+        testTraceFailsAtLastOutput,+        testTraceFailsBeforeLastOutput,+        testTraceIncompleteAtLastOutput,+        testTraceIncompleteBeforeLastOutput,+        testTraceFailsWithQuiescence,+        testOutputOutsideAlphabet,+        testSpecF,+        testPrintSpecF,+        testSpecG,+        testSpecGQuiescent,+        testExponentialNonDeterminism,+        testSTSTestSelection,+        testRandomFCorrect,+        testRandomFIncorrectOutput,+        testRandomFIncorrectInput,+        testSTSHappyFlow,+        testSTSHappyFlowFloat,+        testErrorThrowingGates,+        testSTSUnHappyFlow,+        testPrintSTS,+        testReadAutFile,+        testSTSJSONParserNominal,+        testSTSJSONParserNominalFloat,+        testSTSJSONParserUnknownType,+        testSTSJSONParserUnsupportedGuardOperand,+        testSTSJSONParserUnsupportedAssignmentOperand,+        testSTSJSONParserMissingSwitches,+        testSTSJSONParserMissingGates,+        testSTSJSONParserAssignmentTypeMismatch,+        testSTSJSONParserGuardTypeMismatch,+        testSTSJSONParserGateIdDup,+        testLatticeCoffeeSTS+        ]+        ++ testLatticeSTS+        ++ testLatticeSTSQuiescence+        ++ evalTests+        ++ solveTests++-- TODO: This wraps HUnit tests into a Tasty test.+-- The reason we need this wrapper, is that plain HUnit+-- does not set the exit code, making CI runs pass even+-- when tests fail.+-- Instead, we should migrate the HUnit tests to+-- tasty-hunit, which exposes a very similar interface.+instance Tasty.IsTest HUnit.Test where+  run _ t _ = runTestTT t >>= \c ->+    if errors c + failures c > 0+      then return $ testFailed (show c)+      else return $ testPassed (show c)+  testOptions = pure []+
+ test/Test/Lattest/Adapter/StandardAdapters.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++module Test.Lattest.Adapter.StandardAdapters (+testJSONSocketAdapterByte,+testAdapterAcceptingInput,+testJSONSocketAdapterInt,+testJSONSocketAdapterObject,+testQuiscence,+testInputDelay+)+where++import Lattest.Model.Alphabet(IOAct(..), Suspended(..), IOSuspAct)+import Lattest.Adapter.Adapter(send, Adapter(..), close, observe)+import qualified Lattest.Adapter.Adapter as Adap+import qualified Lattest.Adapter.StandardAdapters as SA+import Lattest.Streams.Synchronized(fromBuffer)++import Control.Concurrent(threadDelay)+import Control.Concurrent.STM.TQueue(TQueue, newTQueueIO, writeTQueue, readTQueue)+import Control.Monad.STM(atomically)+import Data.Aeson(FromJSON,ToJSON)+import Data.ByteString(ByteString)+import qualified Data.ByteString.Char8 as C8 (pack)+import Data.Text(unpack, pack)+import Data.Text.Encoding(decodeUtf8, decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error(lenientDecode)+import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime,nominalDiffTimeToSeconds)+import Data.Functor(void)+import GHC.Conc (forkIO)+import GHC.Generics (Generic)+import Network.Socket(withSocketsDo, accept, SockAddr(SockAddrInet), tupleToHostAddress, setSocketOption, Socket, SocketOption(ReuseAddr,RecvTimeOut))+import qualified Network.Socket as Socket(gracefulClose)+import qualified Network.Socket.ByteString as BSock(recv, send)+import Network.Utils(listenTCPAddr)+import System.IO.Streams(makeOutputStream)+import System.Timeout(timeout)+import Test.HUnit hiding (Path, path)++testJSONSocketAdapterByte :: Test+testJSONSocketAdapterByte = TestCase $ withSocketsDo $ do+    -- TODO use Control.Exception.bracketOnError to do cleanup+    -- TODO fix "threadWait: invalid argument (Bad file descriptor)" message when running these tests. Maybe this has to do with the forked threads in ForkStreams.mux?+    -- test whether the socket adapter works by passing numbers around+    let addr = tupleToHostAddress (127, 0, 0, 1)+    listenSock <- listenTCPAddr (SockAddrInet 2929 addr) 10 -- the SUT listens for adapter connections+    setSocketOption listenSock ReuseAddr 1+    adap <- SA.connectSocketAdapter :: IO (Adapter ByteString ByteString)+    (listenConn, _) <- accept listenSock -- the SUT accepts the adapter connection++    void $ send (C8.pack "1") adap -- the adapter sends 1+    void $ send (C8.pack "2") adap -- the adapter sends 2+    rest <- assertRecv "receive 1 on socket" "1" listenConn+    if null rest+        then void $ assertRecv "receive 2 on socket" "2" listenConn+        else assertEqual "also received 2 on socket" "2" rest+    void $ BSock.send listenConn $ encodeUtf8 . pack $ "3" -- the SUT sends 3 and 4. Not nicely per action, but this should still work because TCP+    threadDelay 2000 -- wait 2ms to ensure that the packets are read separately by the adapter+    void $ BSock.send listenConn $ encodeUtf8 . pack $ "4"+    threadDelay 2000+    assertObserveBytes (C8.pack "3") adap -- the adapter observes 3 from the SUT+    assertObserveBytes (C8.pack "4") adap -- the adapter observes 4 from the SUT+    +    void $ send (C8.pack "5") adap -- the adapter sends 5+    _assertRecv "receive 5" "5" listenConn+    +    void $ BSock.send listenConn $ encodeUtf8 . pack $ "6" -- the SUT sends 6+    assertObserveBytes (C8.pack "6") adap -- the adapter observes 6 from the SUT++    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.+    close adap+    Socket.gracefulClose listenConn 1000+    Socket.gracefulClose listenSock 1000+    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.++testAdapterAcceptingInput :: Test+testAdapterAcceptingInput = TestCase $ do+    icQueue <- newTQueueIO+    ics <- makeOutputStream $ atomically . writeTQueue icQueue+    actQueue <- newTQueueIO+    actionsFromSut' <- fromBuffer actQueue+    let rawAdap = Adapter { inputCommandsToSut = ics, actionsFromSut = actionsFromSut', close = error ""}+    adap <- (SA.acceptingInputs rawAdap) :: IO (Adapter (IOAct Int Int) Int)+    +    void $ send 1 adap -- send an input+    assertObserve 1 adap -- input is observed+    assertReadTQueue 1 icQueue -- input is sent to the underlying adap+    +    void $ send 2 adap -- send an input+    assertReadTQueue 2 icQueue -- input is sent to the underlying adap+    assertObserve 2 adap -- input is observed+    +    atomically $ writeTQueue actQueue (Just 3) -- let underlying adap produce an output+    assertObserve 3 adap -- output is observed+    +    atomically $ writeTQueue actQueue (Just 4) -- let underlying adap produce an output+    assertObserve 4 adap -- output is observed++    void $ send 5 adap -- send an input+    atomically $ writeTQueue actQueue (Just 6) -- let underlying adap produce an output+    assertReadTQueue 5 icQueue -- input is sent to the underlying adap+    assertObserve 5 adap -- input is observed+    threadDelay 100000 -- wait 100ms to ensure that the adap output is received+    assertObserve 6 adap -- output is observed+    +    void $ send 7 adap -- send an input+    atomically $ writeTQueue actQueue (Just 8) -- let underlying adap produce an output+    void $ send 9 adap -- send an input+    atomically $ writeTQueue actQueue (Just 10) -- let underlying adap produce an output+    assertObserve 7 adap -- input is observed+    assertObserveNonDet 8 9 adap -- input and output are observed, in arbitrary order+    threadDelay 100000 -- wait 100ms to ensure that the adap output is received+    assertObserve 10 adap -- output is observed+    assertReadTQueue 7 icQueue -- input is sent to the underlying adap    +    assertReadTQueue 9 icQueue -- input is sent to the underlying adap    ++    where+    assertReadTQueue expected queue = do+        mic <- atomically $ readTQueue queue+        case mic of+            Nothing -> assertFailure $ "Adapter closed unexpectedly while reading '" ++ show expected ++ "'"+            Just ic -> assertEqual ("receiving wrong input command on adap") expected ic++testJSONSocketAdapterInt :: Test+testJSONSocketAdapterInt = TestCase $ withSocketsDo $ do+    -- TODO use Control.Exception.bracketOnError to do cleanup+    -- TODO fix "threadWait: invalid argument (Bad file descriptor)" message when running these tests. Maybe this has to do with the forked threads in ForkStreams.mux?+    -- test whether the socket adapter works by passing numbers around+    let addr = tupleToHostAddress (127, 0, 0, 1)+    listenSock <- listenTCPAddr (SockAddrInet 2929 addr) 10 -- the SUT listens for adapter connections+    setSocketOption listenSock ReuseAddr 1+    adap <- SA.connectJSONSocketAdapterAcceptingInputs :: IO (Adapter (IOAct Int Int) Int) -- the adapter connects, with explicit typing because it should know how to parse incoming data+    (listenConn, _) <- accept listenSock -- the SUT accepts the adapter connection++    void $ send 1 adap -- the adapter sends 1+    void $ send 2 adap -- the adapter sends 2+    _assertRecv "receive 1 and 2 on socket" "1\n2\n" listenConn+    assertObserve 1 adap -- the adapter sees that input 1 was accepted+    assertObserve 2 adap -- the adapter sees that input 2 was accepted+    +    void $ BSock.send listenConn $ encodeUtf8 . pack $ "3" -- the SUT sends 3 and 4. Not nicely per action, but this should still work because TCP+    threadDelay 2000 -- wait 2ms to ensure that the packets are read separately by the adapter+    void $ BSock.send listenConn $ encodeUtf8 . pack $ "\n4"+    threadDelay 2000+    void $ BSock.send listenConn $ encodeUtf8 . pack $ "\n"+    assertObserve 3 adap -- the adapter observes 3 from the SUT+    assertObserve 4 adap -- the adapter observes 4 from the SUT+    +    void $ send 5 adap -- the adapter sends 5+    _assertRecv "receive 5" "5\n" listenConn -- the SUT reads 5 from the adapter.+    assertObserve 5 adap -- the adapter sees that input 5 was accepted++    void $ BSock.send listenConn $ encodeUtf8 . pack $ "6\n" -- the SUT sends 6+    assertObserve 6 adap -- the adapter observes 6 from the SUT++    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.+    close adap+    Socket.gracefulClose listenConn 1000+    Socket.gracefulClose listenSock 1000+    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.++_assertRecv :: String -> String -> Socket -> IO ()+_assertRecv name s sock = void $ assertRecv name s sock++assertRecv :: String -> String -> Socket -> IO String+assertRecv assertName expected sock = do+    setSocketOption sock RecvTimeOut 100000 -- 100 milliseconds. For Windows only, because there 'timeout' doesn't work+    (recvd,rest) <- recvMax $ length expected+    assertEqual assertName expected recvd+    return rest+    where+    recvMax maxChars+        | maxChars <= 0 = return ("", "")+        | otherwise = do+            maybeRecvd <- timeout 100000 $ unpack . decodeUtf8 <$> BSock.recv sock 1024+            case maybeRecvd of+                Nothing -> assertFailure $ "Adapter closed unexpectedly while reading '" ++ show expected ++ "'"+                Just "" -> return ("", "")+                Just recvd -> do+                    if length recvd >= maxChars+                        then return $ splitAt maxChars recvd+                        else do+                            (rest,tl) <- recvMax (maxChars - length recvd)+                            return $ (recvd ++ rest,tl)++assertObserveBytes :: (Show a, Eq a) => a -> Adapter a i -> IO ()+assertObserveBytes expected adap = do+    maybeObserved <- timeout 100000 $ observe adap+    case maybeObserved of+        Nothing -> assertFailure $ "Adapter observation timeout while observing '" ++ show expected ++ "'"+        Just Nothing -> assertFailure $ "Adapter closed unexpectedly while observing '" ++ show expected ++ "'"+        Just (Just observed) -> assertEqual ("receiving wrong output on adap") expected observed++assertObserve :: (Show a, Eq a) => a -> Adapter (IOAct a a) i -> IO ()+assertObserve expected adap = do+    maybeObserved <- timeout 100000 $ observe adap+    case maybeObserved of+        Nothing -> assertFailure $ "Adapter observation timeout while observing '" ++ show expected ++ "'"+        Just Nothing -> assertFailure $ "Adapter closed unexpectedly while observing '" ++ show expected ++ "'"+        Just (Just observed) -> assertEqual ("receiving wrong output on adap") expected (fromIOAct observed)+    where+    fromIOAct :: IOAct a a -> a+    fromIOAct (Out a) = a+    fromIOAct (In a) = a++assertObserveIO :: (Show a, Eq a) => a -> Adapter a i -> IO ()+assertObserveIO expected adap = do+    maybeObserved <- timeout 100000 $ observe adap+    case maybeObserved of+        Nothing -> assertFailure $ "Adapter observation timeout while observing '" ++ show expected ++ "'"+        Just Nothing -> assertFailure $ "Adapter closed unexpectedly while observing '" ++ show expected ++ "'"+        Just (Just observed) -> assertEqual ("receiving wrong observation on adap") expected observed++assertObserveNonDet :: (Show a, Eq a) => a -> a -> Adapter (IOAct a a) i -> IO ()+assertObserveNonDet expected1 expected2 adap = do+    maybeObserved <- timeout 100000 $ observe adap+    case maybeObserved of+        Nothing -> assertFailure $ "Adapter observation timeout while observing '" ++ show expected1 ++ "' / '" ++ show expected2  ++ "'"+        Just Nothing -> assertFailure $ "Adapter closed unexpectedly while observing '" ++ show expected1 ++ "' / '" ++ show expected2  ++ "'"+        Just (Just observed) ->+            if expected2 == fromIOAct observed+                then assertObserve expected1 adap+                else do+                    assertEqual ("receiving wrong output on adap") expected1 (fromIOAct observed)+                    assertObserve expected2 adap+    where+    fromIOAct :: IOAct a a -> a+    fromIOAct (Out a) = a+    fromIOAct (In a) = a++assertObserve' :: (Eq i1, Eq o, Show o, Show i1) => o -> Adapter (IOAct i1 o) i2 -> IO ()+assertObserve' expected adap = do+    maybeObserved <- observe adap+    case maybeObserved of+        Nothing -> assertFailure $ "Adapter closed unexpectedly while observing '" ++ show expected ++ "'"+        Just observed -> assertEqual ("receiving wrong output on adap") (Out expected) observed++data List = Cons { element :: Double, comment :: String, tail :: List } | Nil deriving (Show, Generic, Ord, Eq)+instance FromJSON List+instance ToJSON List++testJSONSocketAdapterObject :: Test+testJSONSocketAdapterObject = TestCase $ withSocketsDo $ do+    -- test whether the socket adapter works by passing numbers around+    let addr = tupleToHostAddress (127, 0, 0, 1)+    listenSock <- listenTCPAddr (SockAddrInet 2929 addr) 10 -- the SUT listens for adapter connections+    setSocketOption listenSock ReuseAddr 1+    adap <- SA.connectJSONSocketAdapterAcceptingInputs :: IO (Adapter (IOAct List List) List) -- the adapter connects, with explicit typing because it should know how to parse incoming data+    (listenConn, _) <- accept listenSock -- the SUT accepts the adapter connection++    let list12 = Cons 1 "first!" $ Cons 2 "second!" Nil+    void $ send list12 adap -- the adapter sends [1,2]+    list12OnSock <- unpack . decodeUtf8 <$> BSock.recv listenConn 1024 -- the SUT reads [1,2] from the adapter.+    -- note: TCP may actually split this into parts. We'll assume it doesn't. If it does, we'll need to write some more flexible reading, or read in between the two sends+    assertEqual "receive [1,2] on socket"+        "{\"comment\":\"first!\",\"element\":1,\"tag\":\"Cons\",\"tail\":{\"comment\":\"second!\",\"element\":2,\"tag\":\"Cons\",\"tail\":{\"tag\":\"Nil\"}}}\n" list12OnSock+    assertObserve list12 adap -- the adapter sees that [1,2] was accepted+    +    let list34 = Cons 3 "third!" $ Cons 4 "fourth!" Nil+    void $ BSock.send listenConn $ encodeUtf8 . pack $+        "{\"comment\":\"third!\",\"element\":3,\"tag\":\"Cons\",\"tail\":{\"comment\":\"fourth!\",\"element\":4,\"tag\":\"Cons\",\"tail\":{\"tag\":\"Nil\"}}}\n" -- the SUT sends [3,4].+    assertObserve list34 adap -- the adapter observes [3,4] from the SUT++    let list56 = Cons 5 "fifth!" $ Cons 6 "sixth!" Nil+    void $ send list56 adap -- the adapter sends [5,6]+    list56OnSock <- unpack . decodeUtf8 <$> BSock.recv listenConn 1024 -- the SUT reads [5,6] from the adapter.+    assertEqual "receive [5,6] on socket"+        "{\"comment\":\"fifth!\",\"element\":5,\"tag\":\"Cons\",\"tail\":{\"comment\":\"sixth!\",\"element\":6,\"tag\":\"Cons\",\"tail\":{\"tag\":\"Nil\"}}}\n" list56OnSock+    assertObserve list56 adap -- the adapter sees that [5,6] was accepted++    let list78 = Cons 7 "seventh!" $ Cons 8 "eighth!" Nil+    void $ BSock.send listenConn $ encodeUtf8 . pack $+        "{\"comment\":\"seventh!\",\"element\":7,\"tag\":\"Cons\",\"tail\":{\"comment\":\"eighth!\",\"element\":8,\"tag\":\"Cons\",\"tail\":{\"tag\":\"Nil\"}}}\n" -- the SUT sends [7,8].+    assertObserve list78 adap -- the adapter observes [7,8] from the SUT++    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.+    close adap+    Socket.gracefulClose listenConn 1000+    Socket.gracefulClose listenSock 1000+    threadDelay 10000 -- FIXME these resolve a clash between the socket test cases. Find a more elegant solution.++++++waitMillis :: Int -> IO ()+waitMillis x = threadDelay $ 1000*x++testQuiscence :: Test+testQuiscence = TestCase $ do+    -- NOTE this tests the timing behaviour of quiescence so is inherently timing-dependent, and therefore potentially unstable. Raise the deltaMillis+    -- and/or marginMillis for increased stability (and increased duration of this test)+    let deltaMillis = 50+    let marginMillis = 20+    let halfDeltaMillis = deltaMillis `div` 2+    let twoAndHalfDeltaMillis = (deltaMillis * 5) `div` 2+    let threeAndHalfDeltaMillis = (deltaMillis * 7) `div` 2+    icQueue <- newTQueueIO+    ics <- makeOutputStream $ atomically . writeTQueue icQueue+    actQueue <- newTQueueIO+    actionsFromSut' <- fromBuffer actQueue+    let rawAdap = Adapter { inputCommandsToSut = ics, actionsFromSut = actionsFromSut', close = error ""}+    stringAdap' <- (Adap.mapTestChoices $ unpack . decodeUtf8With lenientDecode) rawAdap+    stringAdap <- (Adap.mapActionsFromSut $ encodeUtf8 . pack) stringAdap'+    parsingAdap <- SA.parseJSONActionsFromSut stringAdap+    jsonAdap <- SA.encodeJSONTestChoices parsingAdap :: IO (Adapter String String)+    acceptingAdap <- SA.acceptingInputs jsonAdap+    adap <- (SA.withQuiescenceMillis deltaMillis acceptingAdap) :: IO (Adapter (IOSuspAct String String) (Maybe String))++    impQueue <- newTQueueIO+    void $ forkIO $ impFromQueue impQueue actQueue+    +    -- TODO also make a test case which starts with 1) an output, 2) Quiescence, and 3) a Nothing input+    waitMillis halfDeltaMillis+    send (Just "a") adap+    assertObserveIO (In "a") adap+    t1 <- getCurrentTime+    assertObserve' Quiescence adap+    assertObserve' Quiescence adap+    assertObserve' Quiescence adap+    t2 <- getCurrentTime+    assertEqualWithMargin ("t2 - t1") marginMillis (deltaMillis*3) (diffMillis t2 t1)+    sendWithDelay impQueue "1" 0+    assertObserve' (OutSusp "1") adap+    sendWithDelay impQueue "2" 0+    sendWithDelay impQueue "3" 0+    sendWithDelay impQueue "4" 0+    assertObserve' (OutSusp "2") adap+    assertObserve' (OutSusp "3") adap+    assertObserve' (OutSusp "4") adap+    sendWithDelay impQueue "5" halfDeltaMillis+    sendWithDelay impQueue "6" halfDeltaMillis+    sendWithDelay impQueue "7" halfDeltaMillis+    sendWithDelay impQueue "8" halfDeltaMillis+    sendWithDelay impQueue "9" threeAndHalfDeltaMillis+    sendWithDelay impQueue "10" halfDeltaMillis+    assertObserve' (OutSusp "5") adap+    assertObserve' (OutSusp "6") adap+    assertObserve' (OutSusp "7") adap+    assertObserve' (OutSusp "8") adap+    assertObserve' Quiescence adap+    assertObserve' Quiescence adap+    assertObserve' Quiescence adap+    assertObserve' (OutSusp "9") adap+    assertObserve' (OutSusp "10") adap+    send (Just "b") adap+    send (Just "c") adap+    assertObserveIO (In "b") adap+    assertObserveIO (In "c") adap+    assertObserve' Quiescence adap+    waitMillis halfDeltaMillis+    send (Just "d") adap+    assertObserveIO (In "d") adap+    waitMillis halfDeltaMillis+    send (Just "e") adap+    assertObserveIO (In "e") adap+    waitMillis halfDeltaMillis+    send (Just "f") adap+    assertObserveIO (In "f") adap+    waitMillis halfDeltaMillis+    send (Just "g") adap+    assertObserveIO (In "g") adap+    waitMillis twoAndHalfDeltaMillis+    send (Just "h") adap+    assertObserve' Quiescence adap+    assertObserve' Quiescence adap+    assertObserveIO (In "h") adap+    sendWithDelay impQueue "11" halfDeltaMillis+    assertObserve' (OutSusp "11") adap++    -- sending nothing will observe a quiescence before processing the next input +    send Nothing adap+    send (Just "i") adap+    sendWithDelay impQueue "12" 0+    _ <- getCurrentTime+    assertObserve' Quiescence adap+    assertObserveIO (In "i") adap+    assertObserve' (OutSusp "12") adap+    +    -- sending nothing will block until an output is received (before the quiescence timeout)+    sendWithDelay impQueue "13" halfDeltaMillis+    send Nothing adap+    send (Just "j") adap+    _ <- getCurrentTime+    assertObserve' (OutSusp "13") adap+    assertObserveIO (In "j") adap++    atomically $ writeTQueue impQueue Nothing -- close the implementation+++testInputDelay :: Test+testInputDelay = TestCase $ do+    -- NOTE this tests the timing behaviour of input delays so is inherently timing-dependent, and therefore potentially unstable. Raise the deltaMillis+    -- and/or marginMillis for increased stability (and increased duration of this test)+    let delayMillis = 50+    let halfDelayMillis = delayMillis `div` 2+    let deltaMillis = 2*delayMillis+    let oneAndHalfDeltaMillis = (deltaMillis * 3) `div` 2+    let marginMillis = 20+    +    icQueue <- newTQueueIO+    ics <- makeOutputStream $ atomically . writeTQueue icQueue+    actQueue <- newTQueueIO+    actionsFromSut' <- fromBuffer actQueue+    let rawAdap = Adapter { inputCommandsToSut = ics, actionsFromSut = actionsFromSut', close = error ""}+    stringAdap' <- (Adap.mapTestChoices $ unpack . decodeUtf8With lenientDecode) rawAdap+    stringAdap <- (Adap.mapActionsFromSut $ encodeUtf8 . pack) stringAdap'+    parsingAdap <- SA.parseJSONActionsFromSut stringAdap+    jsonAdap <- SA.encodeJSONTestChoices parsingAdap :: IO (Adapter String String)+    acceptingAdap <- SA.acceptingInputs jsonAdap+    adap' <- SA.withQuiescenceMillis deltaMillis acceptingAdap :: IO (Adapter (IOSuspAct String String) (Maybe String))+    adap <- (SA.withSuccessiveInputDelayMillis delayMillis adap') :: IO (Adapter (IOSuspAct String String) (Maybe String))++    impQueue <- newTQueueIO+    void $ forkIO $ impFromQueue impQueue actQueue++    t1 <- getCurrentTime+    send (Just "a") adap+    assertObserveIO (In "a") adap+    t2 <- getCurrentTime+    assertEqualWithMargin ("t2 - t1") marginMillis delayMillis (diffMillis t2 t1)++    t3 <- getCurrentTime+    send (Just "b") adap+    sendWithDelay impQueue "1" 0+    assertObserveIO (In "b") adap+    t4 <- getCurrentTime+    assertObserve' (OutSusp "1") adap+    assertEqualWithMargin ("t4 - t3") marginMillis 0 (diffMillis t4 t3)++    t5 <- getCurrentTime+    send (Just "c") adap+    sendWithDelay impQueue "2" halfDelayMillis+    assertObserveIO (In "c") adap+    t6' <- getCurrentTime+    assertObserve' (OutSusp "2") adap+    t6 <- getCurrentTime+    assertEqualWithMargin ("t6' - t5") marginMillis halfDelayMillis (diffMillis t6' t5)+    assertEqualWithMargin ("t6 - t5") marginMillis halfDelayMillis (diffMillis t6 t5)++    t7 <- getCurrentTime+    send (Just "d") adap+    sendWithDelay impQueue "3" oneAndHalfDeltaMillis+    assertObserveIO (In "d") adap+    t8' <- getCurrentTime+    assertObserve' Quiescence adap+    assertObserve' (OutSusp "3") adap+    t8 <- getCurrentTime+    assertEqualWithMargin ("t8' - t7") marginMillis delayMillis (diffMillis t8' t7)+    assertEqualWithMargin ("t8 - t7") marginMillis oneAndHalfDeltaMillis (diffMillis t8 t7)++    sendWithDelay impQueue "Just to reset the quiescence timer" 0+    assertObserve' (OutSusp "Just to reset the quiescence timer") adap++    t9 <- getCurrentTime+    sendWithDelay impQueue "4" halfDelayMillis+    send Nothing adap+    waitMillis $ oneAndHalfDeltaMillis+    t10 <- getCurrentTime+    assertObserve' (OutSusp "4") adap+    assertObserve' Quiescence adap+    assertEqualWithMargin ("t10 - t9") marginMillis (halfDelayMillis + oneAndHalfDeltaMillis) (diffMillis t10 t9)++    sendWithDelay impQueue "Just to reset the quiescence timer" 0+    assertObserve' (OutSusp "Just to reset the quiescence timer") adap++    t11 <- getCurrentTime+    sendWithDelay impQueue "5" oneAndHalfDeltaMillis+    send Nothing adap+    t12' <- getCurrentTime+    assertObserve' Quiescence adap+    assertObserve' (OutSusp "5") adap+    t12 <- getCurrentTime+    assertEqualWithMargin ("t12' - t11") marginMillis deltaMillis (diffMillis t12' t11)+    assertEqualWithMargin ("t12 - t11") marginMillis oneAndHalfDeltaMillis (diffMillis t12 t11)++    atomically $ writeTQueue impQueue Nothing -- close the implementation++assertEqualWithMargin :: String -> Int -> Int -> Int -> Assertion+assertEqualWithMargin msg margin expected actual = +    let msg' = msg ++ ": expected " ++ show expected ++ "±" ++ show margin ++ ", was " ++ show actual+    in assertBool msg' $ actual <= expected + margin && actual >= expected - margin++diffMillis :: Integral b => UTCTime -> UTCTime -> b+diffMillis t2 t1 = ceiling $ 1000 * (nominalDiffTimeToSeconds $ diffUTCTime t2 t1)++impFromQueue :: TQueue (Maybe (String, Int)) -> TQueue (Maybe String) -> IO ()+impFromQueue impQueue actQueue = do+    mOut <- atomically $ readTQueue impQueue+    case mOut of+        Just (out, delay) -> do+            waitMillis delay+            atomically $ writeTQueue actQueue $ Just out+            impFromQueue impQueue actQueue+        Nothing -> return ()++sendWithDelay :: TQueue (Maybe (String, Int)) -> String -> Int -> IO ()+sendWithDelay impQueue act delay = do+    atomically $ writeTQueue impQueue $ Just (show act, delay)
+ test/Test/Lattest/Exec/NComplete.hs view
@@ -0,0 +1,52 @@+module Test.Lattest.Exec.NComplete(testADG,testAccSeq)+where++import Test.HUnit+import qualified Data.Map as Map (Map,lookup)+import qualified Data.Set as Set (Set)++import Lattest.Exec.ADG.Aut(adgAutFromAutomaton)+import Lattest.Exec.ADG.DistGraph(computeAdaptiveDistGraph)+import Lattest.Exec.ADG.SplitGraph(Evidence(..))+import Lattest.Model.Alphabet(IOAct(..))+import Lattest.Model.BoundedMonad(Det(..))+import Lattest.Model.Automaton(AutSyntax)+import Lattest.Model.StandardAutomata(ConcreteSuspAutIntrpr, accessSequences, detConcTransFromRel,ioAlphabet,automaton,interpretQuiescentConcrete, accessSequences)++trans :: Integer -> Map.Map (IOAct String String) (Det ((), Integer))+Just trans = detConcTransFromRel+    [   (1, In "a", 3),+        (1, Out "x", 1),+        (1, Out "y", 1),+        (2, In "a", 4),+        (2, Out "x", 4),+        (3, Out "x", 4),+        (4, Out "y", 2)+    ] :: Maybe (Integer -> Map.Map (IOAct String String) (Det ((), Integer)))+alphabet :: Set.Set (IOAct String String)+alphabet = ioAlphabet ["a"] ["x", "y"]+initialConfiguration :: Det Integer+initialConfiguration = pure 1+spec :: AutSyntax Det Integer (IOAct String String) ()+spec = automaton initialConfiguration alphabet trans+model :: ConcreteSuspAutIntrpr Det Integer String String+model = interpretQuiescentConcrete spec++testADG :: Test+testADG = TestCase $ do+    let adgaut = case adgAutFromAutomaton model "delta" of+            Just a -> a+            Nothing ->  error "could not transform Lattest auomaton into ADG automaton"+        adg = computeAdaptiveDistGraph adgaut False True True+    assertEqual "ADG of ADG-journal automaton: " adg+        $ Plus [Prefix "x" $ Plus [Prefix "x" Nil,+                                 Prefix "y" $ Prefix "a" $ Plus [Prefix "x" Nil, Prefix "y" Nil]],+               Prefix "y" $ Prefix "a" $ Plus [Prefix "x" Nil, Prefix "y" Nil]]++testAccSeq :: Test+testAccSeq = TestCase $ do+    let accMap = accessSequences model 1+    assertEqual "empty seq for loc 1" (Just []) $ Map.lookup 1 accMap+    assertEqual "axy expected for loc 2" (Just $ [In "a", Out "x", Out "y"]) $ Map.lookup 2 accMap+    assertEqual "a expected for loc 3" (Just $ [In "a"]) $ Map.lookup 3 accMap+    assertEqual "ax expected for loc 4" (Just $ [In "a", Out "x"]) $ Map.lookup 4 accMap
+ test/Test/Lattest/Exec/StandardTestControllers.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveGeneric #-}+module Test.Lattest.Exec.StandardTestControllers (+testRandomFCorrect,+testRandomFIncorrectOutput,+testRandomFIncorrectInput+)+where++import Test.HUnit hiding (Path, path)++import Test.Lattest.Model.StandardAutomata(IF(..),OF(..),StateF,sf)++-- TODO prototype imports, (re)move or insert into alphabetical order+import Lattest.Exec.StandardTestControllers+import Lattest.Exec.Testing(TestController(..), Verdict(..), runTester, Verdict(Pass))+import Lattest.Model.BoundedMonad(isConclusive, isForbidden)+import qualified Lattest.Model.BoundedMonad as BM (FreeLattice)+import Lattest.Model.StandardAutomata(interpretQuiescentInputAttemptConcrete)+import Lattest.Model.Alphabet(IOAct(..), Suspended(..), SuspendedIF, InputAttempt(..))+import Lattest.Adapter.Adapter(Adapter(..))+import System.Random(StdGen, mkStdGen)+import qualified Data.Map as Map (Map, fromList)+import Lattest.Adapter.StandardAdapters(pureAdapter)++nrSteps :: Int+nrSteps = 50+testSelector :: TestController BM.FreeLattice StateF StateF (IOAct IF OF) () (SuspendedIF IF OF) ((((StdGen, Int), [SuspendedIF IF OF]), Maybe (BM.FreeLattice StateF)), Maybe (BM.FreeLattice StateF)) (Maybe IF) (([SuspendedIF IF OF], Maybe (BM.FreeLattice StateF)), Maybe (BM.FreeLattice StateF))+testSelector = randomTestSelectorFromSeed 456 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver++x :: IOAct i OF+x = Out X+y :: IOAct i OF+y = Out Y+af :: IOAct IF o+af = In A+bf :: IOAct IF o+bf = In B++data StateFDet = Q0fd | Q1fd | Q2fd deriving (Show, Eq, Ord)+tFDetCorrect :: StateFDet -> Map.Map (IOAct IF OF) StateFDet+tFDetCorrect Q0fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q0fd)]+tFDetCorrect Q1fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q2fd)]+tFDetCorrect Q2fd = Map.fromList [(af, Q1fd), (bf, Q0fd), (y, Q2fd)]+impFDetCorrect :: IO (Adapter (SuspendedIF IF OF) (Maybe IF))+impFDetCorrect = pureAdapter (mkStdGen 123) 0.5 tFDetCorrect Q0fd++testRandomFCorrect :: Test+testRandomFCorrect = TestCase $ do+    imp <- impFDetCorrect+    let model = interpretQuiescentInputAttemptConcrete sf+    (verdict, ((observed, maybeMq), _)) <- runTester model testSelector imp+    assertEqual "testRandomFCorrect should pass" Pass verdict+    assertEqual "incorrect number of observations made" nrSteps (length observed)+    assertEqual "final state should be inconclusive" (Just True) (not . isConclusive <$> maybeMq)++tFDetIncorrectOutput :: StateFDet -> Map.Map (IOAct IF OF) StateFDet+tFDetIncorrectOutput Q0fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q0fd)]+tFDetIncorrectOutput Q1fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q2fd)]+tFDetIncorrectOutput Q2fd = Map.fromList [(af, Q1fd), (bf, Q0fd), (x, Q2fd), (y, Q2fd)] -- incorrect x-transition+impFDetIncorrectOutput :: IO (Adapter (SuspendedIF IF OF) (Maybe IF))+impFDetIncorrectOutput = pureAdapter (mkStdGen 123) 0.5 tFDetIncorrectOutput Q0fd++testRandomFIncorrectOutput :: Test+testRandomFIncorrectOutput = TestCase $ do+    imp <- impFDetIncorrectOutput+    let model = interpretQuiescentInputAttemptConcrete sf+    (verdict, ((observed, maybeMq), maybePrvMq)) <- runTester model testSelector imp+    let prev = last $ init observed+    assertEqual "testRandomFIncorrectOutput should fail" Fail verdict+    assertBool "incorrect number of observations " $ nrSteps >= length observed+    -- the only non-conformance is the output Y from Q2fd+    assertEqual "expected test failure on !Y" (Out $ OutSusp X) (last observed)+    -- the only observations leading to Q2fd are X and Y+    assertBool "expected observation before the test failure to be !X or !Y" $ (Out $ OutSusp X) == prev || (Out $ OutSusp Y) == prev+    assertEqual "state before the final state should be inconclusive" (Just True) (not . isConclusive <$> maybePrvMq)+    assertEqual "final state should be conclusive" (Just True) (isConclusive <$> maybeMq)++tFDetIncorrectInput :: StateFDet -> Map.Map (IOAct IF OF) StateFDet+tFDetIncorrectInput Q0fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q0fd)]+tFDetIncorrectInput Q1fd = Map.fromList [(af, Q1fd), (x, Q0fd), (y, Q2fd)]+tFDetIncorrectInput Q2fd = Map.fromList [(af, Q1fd), (y, Q2fd)] -- incorrect absence of a b-transition+impFDetIncorrectInput :: IO (Adapter (SuspendedIF IF OF) (Maybe IF))+impFDetIncorrectInput = pureAdapter (mkStdGen 123) 0.5 tFDetIncorrectInput Q0fd++testRandomFIncorrectInput :: Test+testRandomFIncorrectInput = TestCase $ do+    imp <- impFDetIncorrectInput+    let model = interpretQuiescentInputAttemptConcrete sf+    (verdict, ((observed, maybeMq), _)) <- runTester model testSelector imp+    let prev = last $ init observed+    assertEqual "testRandomFIncorrectInput should fail" Fail verdict+    assertBool "incorrect number of observations " $ nrSteps >= length observed+    -- the only non-conformance is the output Y from Q2fd+    assertEqual "expected test failure on ?B" (In $ InputAttempt(B, False)) (last observed)+    -- the only observation leading to Q2fd is Y+    assertBool "expected observation before the test failure to be !X or !Y" $ (Out $ OutSusp X) == prev || (Out $ OutSusp Y) == prev+    assertEqual "final state should be forbidden" (Just True) (isForbidden <$> maybeMq)+    +++
+ test/Test/Lattest/Exec/Testing.hs view
@@ -0,0 +1,176 @@+module Test.Lattest.Exec.Testing (+testTraceHappy,+testTraceFailsAtLastOutput,+testTraceFailsBeforeLastOutput,+testTraceIncompleteAtLastOutput,+testTraceIncompleteBeforeLastOutput,+testTraceFailsWithQuiescence,+testOutputOutsideAlphabet+)+where++import Test.HUnit hiding (Path, path)++import Lattest.Exec.Testing(TestController(..), Verdict(..), runTester, Verdict(Pass))+import Lattest.Model.Automaton(AutSyntax, automaton)+import Lattest.Model.StandardAutomata(interpretQuiescentConcrete)+import Lattest.Model.Alphabet(IOAct(..), IOSuspAct, Suspended(..), SuspendedIF)+import Lattest.Model.BoundedMonad+import qualified Data.Map as Map (Map, insert, fromList)+import Data.Maybe (fromJust)+import Lattest.Adapter.StandardAdapters(Adapter,pureMealyAdapter)++import Lattest.Adapter.StandardAdapters(pureAdapter)+import System.Random(StdGen, mkStdGen)+import Lattest.Model.StandardAutomata(interpretQuiescentInputAttemptConcrete, detConcTransFromRel)+import Lattest.Exec.StandardTestControllers+++testTraceHappy :: Test+testTraceHappy = TestCase $ do+    let t = [In 1, In 2, Out 3, In 4, Out 5, Out 6] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification t) (ioTraceTestController t) adap+    assertEqual "testTraceHappy should pass" verdict Pass+    assertEqual "testTraceHappy should be complete" finished True++testTraceFailsAtLastOutput :: Test+testTraceFailsAtLastOutput = TestCase $ do+    let t = [Out 1, Out 1, Out 2] :: [IOAct Integer Integer]+    let tspec = [Out 1, Out 2] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification tspec) (ioTraceTestController tspec) adap+    assertEqual "testTraceFailsAtLastOutput should fail" Fail verdict +    assertEqual "testTraceFailsAtLastOutput should be complete" True finished++testTraceFailsBeforeLastOutput :: Test+testTraceFailsBeforeLastOutput = TestCase $ do+    let t = [Out 1, Out 2] :: [IOAct Integer Integer]+    let tspec = [Out 2, Out 1] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification tspec) (ioTraceTestController tspec) adap+    assertEqual "testTraceFailsBeforeLastOutput should fail" Fail verdict+    assertEqual "testTraceFailsBeforeLastOutput should be incomplete" False finished++testTraceIncompleteAtLastOutput :: Test+testTraceIncompleteAtLastOutput = TestCase $ do+    let t = [Out 1, Out 2] :: [IOAct Integer Integer]+    let tController = [Out 1, Out 1] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification t) (ioTraceTestController tController) adap+    assertEqual "testTraceIncompleteAtLastOutput should pass" Pass verdict +    assertEqual "testTraceIncompleteAtLastOutput should be complete" True finished++testTraceIncompleteBeforeLastOutput :: Test+testTraceIncompleteBeforeLastOutput = TestCase $ do+    let t = [Out 1, Out 2] :: [IOAct Integer Integer]+    let tController = [Out 2, Out 2] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification t) (ioTraceTestController tController) adap+    assertEqual "testTraceIncompleteBeforeLastOutput should pass" Pass verdict+    assertEqual "testTraceIncompleteBeforeLastOutput should be incomplete" False finished++testTraceFailsWithQuiescence :: Test+testTraceFailsWithQuiescence = TestCase $ do+    let t = [Out 1, In 2] :: [IOAct Integer Integer]+    let tspec = [Out 1, Out 2] :: [IOAct Integer Integer]+    adap <- traceAdapter t+    (verdict, finished) <- runTester (interpretQuiescentConcrete $ traceSpecification tspec) (ioTraceTestController tspec) adap+    assertEqual "testTraceFailsWithQuiescence should fail" Fail verdict+    assertEqual "testTraceFailsWithQuiescence should be incomplete" True finished++ioTraceTestController :: (Eq i, Eq o) => [IOAct i o] -> TestController m loc q t tdest (IOSuspAct i o) [Either (Maybe i) (IOSuspAct i o)] (Maybe i) Bool+ioTraceTestController ioActs = traceTestController $ toCommandsAndActs ioActs+    where+    toCommandsAndActs [] = []+    toCommandsAndActs (In i:rest) = Left (Just i) : Right (In i) : toCommandsAndActs rest+    toCommandsAndActs (Out o:rest) = Right (Out $ OutSusp o) : toCommandsAndActs rest++-- a hardcoded test controller just follows the input commands and observations in the given list. Returns whether it finish the list+traceTestController :: (Eq act) => [Either (Maybe i) act] -> TestController m loc q t tdest act [Either (Maybe i) act] (Maybe i) Bool+traceTestController steps = TestController {+    -- testControllerState :: (TestChoice i act) => [Either i act]+    testControllerState = steps,+    --selectTest :: (TestChoice i act) => [Either i act] -> AutIntrpr m loc q t tdest act -> m q -> IO (Either (i, [Either i act]) Boolean),+    selectTest = traceSelectTest,+    --updateTestController :: [Either i act] -> AutIntrpr m loc q t tdest act -> act -> m q -> IO (Either [Either i act] Boolean),+    updateTestController = traceUpdateTestController,+    --handleTestClose :: [Either i act] -> IO Boolean -- When testing finishes, return a result+    handleTestClose = return . null+    }+    where+    traceSelectTest [] _ _ = return $ Right True+    traceSelectTest (Left (Just i):steps') _ _ = return $ Left (Just i, steps')+    traceSelectTest (Right act:steps') _ _ = return $ Left (Nothing, (Right act:steps')) -- the test controller must choose input but it wanted to make an observation.+    traceSelectTest _ _ _ = error "should not happen"+    traceUpdateTestController [] _ _ _ = return $ Right True+    traceUpdateTestController (Left _:_) _ _ _ = return $ Right False -- test controller makes an observation but wanted to choose an input+    traceUpdateTestController (Right expectedAct:steps') _ act _ = return $ if expectedAct == act then Left steps' else Right (null steps')++traceSpecification :: (Ord i, Ord o) => [IOAct i o] -> AutSyntax Det [IOAct i o] (IOAct i o) () -- TODO automata are inconsistent: no explicit alphabet, but an explicit transition map+traceSpecification steps = automaton (if null steps then UnderspecDet else Det steps) steps traceTransRel+    where+    traceTransRel (step:steps') = Map.insert step (Det ((), steps')) baseTransRel+    traceTransRel [] = baseTransRel+    baseTransRel = Map.fromList [(act, detStateFromAct act) | act <- steps]+    detStateFromAct (In _) = UnderspecDet+    detStateFromAct (Out _) = ForbiddenDet+{-+traceAdapter :: (Show i, Show o) => [IOAct i o] -> IO (Adapter (IOSuspAct i o) (Maybe i))+traceAdapter steps = pureAdapter traceTrans traceOutput $ if (null $ takeOutputs steps) then steps else error "traceAdapter cannot start with output"+    where+    -- invariant: before and in between transitions, the first step is always an input+    traceTrans steps' _ = snd (span isOutput steps') -- after the first input, drop all next outputs+    traceOutput steps' _ = takeOutputs steps' -- after the first input, take all next outputs+    takeOutputs steps' = fst (span isOutput steps')+-}+traceAdapter :: (Eq i) => [IOAct i o] -> IO (Adapter (IOSuspAct i o) (Maybe i))+traceAdapter steps = pureMealyAdapter traceTrans traceOutput steps+    where+    traceTrans [] _ = []+    traceTrans (In is:steps') (Just i) = if i == is then steps' else []+    traceTrans (In is:steps') Nothing = (In is:steps')+    traceTrans (Out _:steps') _ = steps' -- potential race condition between the (Just i) and the output. Let the adapter win to pester the tester+    traceOutput [] _ = [Out Quiescence] -- if the adapter is not processing any more actions, show timeouts. Even if an input is attempted, because it will not be processed+    traceOutput (In _:_) (Just i) = [In i]+    traceOutput (In _:_) Nothing = [Out Quiescence] -- the adapter is waiting for an input but doesn't receive one, so show a timeout.+    traceOutput (Out os:_) _ = [Out $ OutSusp os] -- potential race condition between the (Just i) and the output. Let the adapter win to pester the tester++testSelector :: TestController Det StateFDet StateFDet (IOAct IF OF) () (SuspendedIF IF OF) ((((StdGen, Int), [SuspendedIF IF OF]), Maybe (Det StateFDet)), Maybe (Det StateFDet)) (Maybe IF) (([SuspendedIF IF OF], Maybe (Det StateFDet)), Maybe (Det StateFDet))+testSelector = randomTestSelectorFromSeed 456 `untilCondition` stopAfterSteps 50+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver++data IF = A deriving (Show, Eq, Ord)+data OF = X | Y deriving (Show, Eq, Ord)+data StateFDet = Q0fd deriving (Show, Eq, Ord)+xf :: IOAct i OF+xf = Out X+yf :: IOAct i OF+yf = Out Y+af :: IOAct IF o+af = In A+q0f :: Det StateFDet+q0f = pure Q0fd+tWithX :: StateFDet -> Map.Map (IOAct IF OF) StateFDet+tWithX Q0fd = Map.fromList [(af, Q0fd), (xf, Q0fd)]+impWithX :: IO (Adapter (SuspendedIF IF OF) (Maybe IF))+impWithX = pureAdapter (mkStdGen 123) 0.0 tWithX Q0fd++menuWithY :: [IOAct IF OF]+menuWithY = [af, yf]+tWithY :: StateFDet -> Map.Map (IOAct IF OF) (Det ((), StateFDet))+tWithY = fromJust $ detConcTransFromRel [(Q0fd, af, Q0fd), (Q0fd, yf, Q0fd)]+specWithY :: AutSyntax Det StateFDet (IOAct IF OF) ()+specWithY = automaton q0f menuWithY tWithY++testOutputOutsideAlphabet :: Test+testOutputOutsideAlphabet = TestCase $ do+    imp <- impWithX+    let model = interpretQuiescentInputAttemptConcrete specWithY+    (verdict, ((_, _), _)) <- runTester model testSelector imp+    case verdict of+        Inconclusive _ -> return ()+        _ -> assertFailure $ "Output outside alphabet used, expected inconclusive verdict instead of " ++ show verdict+++
+ test/Test/Lattest/Model/BoundedMonad.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Lattest.Model.BoundedMonad (+prop_latticeIsCNF,+LatticeOp+)+where++import Test.QuickCheck+import qualified Lattest.Model.BoundedMonad as BM+import qualified Reference.FreeLatticeSlow as FL++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Control.Monad as CM+import qualified Debug.Trace as Trace++-- operations for constructing free lattices. The Map of the Bind operation contains keys for exactly all free  variables in the bound lattice+data LatticeOp a = Var a | Top | Bot | Join (LatticeOp a) (LatticeOp a) | Meet (LatticeOp a) (LatticeOp a) | Bind (LatticeOp a) (Map.Map a (LatticeOp a)) deriving (Eq, Ord, Show)++-- the free variables after performing the operations (in case of bind, only the free variables after substitution)+freeVars :: Ord a => LatticeOp a -> Set.Set a+freeVars (Var a) = Set.singleton a+freeVars (Join x y) = freeVars x `Set.union` freeVars y+freeVars (Meet x y) = freeVars x `Set.union` freeVars y+freeVars (Bind _ subs) = Set.unions $ freeVars <$> Map.elems subs+freeVars _ = Set.empty++instance (Arbitrary a, Ord a) => Arbitrary (LatticeOp a) where+    arbitrary = sized arbitrary'+        where+        arbitrary' 0 = oneof [+            Var <$> arbitrary,+            return Top,+            return Bot+            ]+        arbitrary' n = oneof [+            Var <$> arbitrary,+            return Top,+            return Bot,+            CM.liftM2 Join sub sub,+            CM.liftM2 Meet sub sub,+            sub >>= wrapInBind (n - 1)+            ]+            where+                sub = arbitrary' (n - 1)+                wrapInBind n' a = Bind a <$> (arbitraryMapping n' $ Set.toList $ freeVars a)+                arbitraryMapping n' vars = Map.fromList <$> sequence (arbitraryIdPlusLatticeOp n' <$> vars)+                arbitraryIdPlusLatticeOp n' a = do+                    l <- arbitrary' n'+                    return (a, l)+    shrink Top = []+    shrink Bot = []+    shrink (Var _) = [Top, Bot]+    shrink (Join x y) = [Join x' y' | (x', y') <- shrink (x, y)] ++ shrink x ++ shrink y+    shrink (Meet x y) = [Meet x' y' | (x', y') <- shrink (x, y)] ++ shrink x ++ shrink y+    shrink (Bind l subs) = [let subs' = Map.restrictKeys subs (freeVars l') in if Map.null subs then l' else (Bind l' subs') | l' <- shrink l]+                            ++ [Bind l subs' | subs' <- simplifiedSubs]+        where+        simplifiedSubs = [ Map.insert var sub subs | (var,sub) <- Map.toList subs, _ <- shrink sub ]++constructLattice :: (BM.BoundedConfiguration l, BM.JoinSemiLattice (l a), BM.MeetSemiLattice (l a), BM.OrdMonad l, Ord a) => LatticeOp a -> l a+constructLattice Top = BM.underspecified+constructLattice Bot = BM.forbidden+constructLattice (Var a) = BM.ordReturn a+constructLattice (Join x y) = (constructLattice x) BM.\/ (constructLattice y)+constructLattice (Meet x y) = (constructLattice x) BM./\ (constructLattice y)+constructLattice (Bind l subs) =+    let subs' = Map.map constructLattice subs +    in (constructLattice l) `BM.ordBind` (subs' Map.!) ++prop_latticeIsCNF :: (Ord a, Show a) => LatticeOp a -> Bool+prop_latticeIsCNF l = +    let cnf = constructLattice l+        standard = constructLattice l+        outcome = (cnfToLattice $ cnf) == standard+        message = "CNF:\n" ++ show cnf ++ "\n\nstandard:\n" ++ show standard ++ "\n\n"+    in if outcome then True else Trace.trace message False+    where+    cnfToLattice :: BM.FreeLattice a -> FL.FreeLatticeSlow a+    cnfToLattice (BM.FreeLattice ls) = cnfToLattice' ls+    cnfToLattice' = Set.foldr mergeConjunct BM.underspecified+    mergeConjunct :: Set.Set a -> FL.FreeLatticeSlow a -> FL.FreeLatticeSlow a+    mergeConjunct conjunct l' = conjunctToLattice conjunct BM./\ l'+    conjunctToLattice = Set.foldr mergeDisjunct BM.forbidden+    mergeDisjunct :: a -> FL.FreeLatticeSlow a -> FL.FreeLatticeSlow a+    mergeDisjunct a l' = return a BM.\/ l'++++++++++++++++
+ test/Test/Lattest/Model/STSTest.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}++module Test.Lattest.Model.STSTest (+    testSTSHappyFlow,+    testSTSHappyFlowFloat,+    testLatticeCoffeeSTS,+    testErrorThrowingGates,+    testSTSUnHappyFlow,+    testPrintSTS,+    testSTSTestSelection,+    testLatticeSTS,+    testLatticeSTSQuiescence+    )+where++import Prelude hiding (take)+import Test.HUnit+import Data.Maybe(fromJust)+import qualified Data.Set as Set+import System.Random(mkStdGen)+import Data.String(IsString)+import qualified Text.RawString.QQ as QQ+import qualified Lattest.Adapter.Adapter as Adapter+import Lattest.Adapter.StandardAdapters(pureAdapter)+import Lattest.Exec.StandardTestControllers+import Lattest.Exec.Testing(runSMTTester, Verdict(..))+import Lattest.Model.Automaton(after, stateConf,automaton,IntrpState(..),prettyPrintIntrp,stsTLoc)+import Lattest.Model.StandardAutomata(interpretSTS, IOSTS, STSIntrp, interpretSTSQuiescentInputAttemptConcrete)+import Lattest.Model.Alphabet(IOAct(..), Suspended(..), SuspendedIF, SuspendedIFGateValue, δ, SymInteract(..),GateValue(..), gateValueAsIOAct,toIOGateValue, InputAttempt(..))+import Lattest.Model.BoundedMonad(Det, (/\), (\/), underspecified, forbidden, FreeLattice, atom, disjunction)+import Reference.FreeLatticeSlow(FreeLatticeSlow)+import qualified Data.Map as Map+import qualified Control.Exception as Exception+import Lattest.Model.Symbolic.Expr+import qualified Lattest.SMT as SMT++pvar :: Variable+pvar = (Variable "p" IntType)+qvar :: Variable+qvar = (Variable "q" IntType)+xvar :: Variable+xvar = (Variable "x" IntType)+stsExampleInitAssign :: Valuation+stsExampleInitAssign = fromConstantsMap $ Map.singleton xvar (Cint 0)++stsExample :: IOSTS Det Integer String String+stsExample =+    let p = sVar pvar :: Expr Integer+        x = sVar xvar :: Expr Integer+        water = SymInteract (In "water") [pvar]+        ok = SymInteract (Out "ok") [pvar]+        coffee = SymInteract (Out "coffee") []+        waterGuard = 1 .<= p .&& p .<= 10+        waterAssign = assignment [xvar =: x .+ p]+        okGuard = x .== p+        coffeeGuard = x .>= 15+        initConf = return 0+        switches = \q -> case q of+            0 -> Map.fromList [(water, pure (stsTLoc waterGuard waterAssign, 1)),+                                (coffee, pure (stsTLoc coffeeGuard noAssignment, 2))]+            1 -> Map.fromList [(ok, pure (stsTLoc okGuard noAssignment, 0))]+            2 -> Map.empty+    in automaton initConf (Set.fromList [water,ok,coffee]) switches+stsExampleIntrpr :: STSIntrp Det Integer (IOAct String String)+stsExampleIntrpr = interpretSTS stsExample stsExampleInitAssign++getSTSIntrpState :: Integer ->  Integer -> Det (IntrpState Integer)+getSTSIntrpState loc val = pure $ IntrpState loc $ fromConstantsMap $ Map.singleton (Variable "x" IntType) (Cint val)++testSTSHappyFlow :: Test+testSTSHappyFlow = TestCase $ do++    assertEqual "\ninitial state " (getSTSIntrpState 0 0) (stateConf stsExampleIntrpr)+    let intrp2 = after stsExampleIntrpr (GateValue (In "water") [Cint 7])+    assertEqual "after water 7: " (getSTSIntrpState 1 7) (stateConf intrp2)+    let intrp3 = after intrp2 (GateValue (Out "ok") [Cint 7])+    assertEqual "after ok 7: " (getSTSIntrpState 0 7) (stateConf intrp3)+    let intrp4 = after intrp3 (GateValue (In "water") [Cint 9])+    assertEqual "after water 9: " (getSTSIntrpState 1 16) (stateConf intrp4)+    let intrp5 = after intrp4 (GateValue (Out "ok") [Cint 16])+    assertEqual "after ok 16: " (getSTSIntrpState 0 16) (stateConf intrp5)+    let intrp6 = after intrp5 (GateValue (Out "coffee") [])+    assertEqual "after coffee: " (getSTSIntrpState 2 16) (stateConf intrp6)+    return()++testErrorThrowingGates :: Test+testErrorThrowingGates = TestCase $ do+    let intrp1 = after stsExampleIntrpr (GateValue (Out "water") [Cint 7])+    assertThrowsError "gate not in STS alphabet" (stateConf intrp1)+    let intrp2 = after stsExampleIntrpr (GateValue (In "water") [])+    assertThrowsError "nr of values unequal to nr of parameters: 0 values and 1 variables" (stateConf intrp2)+    let intrp3 = after stsExampleIntrpr (GateValue (In "water") [Cbool True])+    assertThrowsError "type of variable and value do not match. Variables: [p:Int], Values: [True]" (stateConf intrp3)++testSTSUnHappyFlow :: Test+testSTSUnHappyFlow = TestCase $ do+    let intrp3 = after stsExampleIntrpr (GateValue (Out "ok") [Cint 0]) -- output not enabled+    assertEqual "after ok: " forbidden (stateConf intrp3)+    let intrp4 = after stsExampleIntrpr (GateValue (In "water") [Cint 11]) -- value for input does not satisfy guard+    assertEqual "after water 11: " underspecified (stateConf intrp4)+    let intrp5 = after stsExampleIntrpr (GateValue (Out "coffee") []) -- value of variable does not satisfy guard+    assertEqual "after coffee: " forbidden (stateConf intrp5)++assertThrowsError :: String -> a -> IO ()+assertThrowsError expectedError someVal = do+    actualError <- Exception.handle handler $ do+        _ <- Exception.evaluate someVal+        return Nothing -- no exception thrown, so no error message+    assertEqual "expected error: " (Just expectedError) actualError+    where+        handler :: Exception.ErrorCall -> IO (Maybe String)+        handler ex = return $ Just $ show ex++testPrintSTS :: Test+testPrintSTS = TestCase $ assertBool failureMessage (expected == actual) -- no assertEquals to avoid printing the unreadable ascii-escaped variant of the tested unicode strings+    where+    failureMessage = "print of STS does not match, expected:" ++ expected ++ "but received:" ++ actual+    actual = "\n" ++ prettyPrintIntrp stsExampleIntrpr ++ "\n" -- newlines before and after to match those of the "expected" below.+    -- fancy quasiquotes to allow direct copy-pasting of the printed expected string into the source code below. With newline at start and end for readability.+    expected = [QQ.r|+current state configuration: (0,{x:=0})+initial location configuration: 0+locations: 0, 1, 2+transitions:+0  ――?"water" [p:Int]⟶  ((((-p+10)) ≥ 0)∧(((p+-1)) ≥ 0), {x:=(p+x)},1)+0  ――!"coffee" []⟶  (((x+-15)) ≥ 0, {},2)+0  ――!"ok" [p:Int]⟶  -forbidden-+1  ――?"water" [p:Int]⟶  -underspecified-+1  ――!"coffee" []⟶  -forbidden-+1  ――!"ok" [p:Int]⟶  ((x) = (p), {},0)+2  ――?"water" [p:Int]⟶  -underspecified-+2  ――!"coffee" []⟶  -forbidden-+2  ――!"ok" [p:Int]⟶  -forbidden-+|]++data ImpExampleLoc = L0 | L1 | L2 deriving (Eq, Ord, Show)++-- TODO the "x" here is not implemented properly, it should be something like "xvar = (Variable "x" IntType)", see the example at the top of this file+tExampleCorrect :: (Ord i, Ord o, IsString i, IsString o) => (ImpExampleLoc, Integer) -> Map.Map (GateValue (IOAct i o)) (ImpExampleLoc, Integer)+tExampleCorrect (L0, x) = Map.fromList $+    [((GateValue (In "water") [Cint p]), (L1, x+p)) | p <- [1..10]] ++ [((GateValue (Out "coffee") []), (L2, 0)) | x > 15]+tExampleCorrect (L1, x) = Map.fromList $ [((GateValue (Out "ok") [Cint x]), (L0, x))]+tExampleCorrect (L2, _) = Map.fromList $ []+impExampleCorrect :: IO (Adapter.Adapter (SuspendedIFGateValue String String) (Maybe (GateValue String)))+impExampleCorrect = do+    imp <- pureAdapter (mkStdGen 123) 0.5 (Map.mapKeys gateValueAsIOAct <$> tExampleCorrect) (L0, 0) :: IO (Adapter.Adapter (SuspendedIF (GateValue String) (GateValue String)) (Maybe (GateValue String)))+    Adapter.mapActionsFromSut toIOGateValue imp++testSTSTestSelection :: Test+testSTSTestSelection = TestCase $ do+    let nrSteps = 37++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.05 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impExampleCorrect+    (verdict, ((observed, _), _)) <- runSMTTester (interpretSTSQuiescentInputAttemptConcrete stsExample stsExampleInitAssign) testSelector imp+    let checkObserved = go 0 0 observed+    let exampleObserved = [+          inp "water" [Cint 1],+          out "ok" [Cint 1],+          inp "water" [Cint 1],+          out "ok" [Cint 2],+          GateValue δ [],+          inp "water" [Cint 1],+          out "ok" [Cint 3],+          inp "water" [Cint 1],+          outL "ok" [Cint 4],+          inpL "water" [Cint 1],+          outL "ok" [Cint 5],+          GateValue δ [],+          inpL "water" [Cint 1],+          outL "ok" [Cint 6],+          inpL "water" [Cint 1],+          outL "ok" [Cint 7],+          inpL "water" [Cint 1],+          outL "ok" [Cint 8],+          inpL "water" [Cint 1],+          outL "ok" [Cint 9],+          inpL "water" [Cint 1],+          outL "ok" [Cint 10],+          inpL "water" [Cint 1],+          outL "ok" [Cint 11],+          inpL "water" [Cint 1],+          outL "ok" [Cint 12],+          inpL "water" [Cint 1],+          outL "ok" [Cint 13],+          inpL "water" [Cint 1],+          outL "ok" [Cint 14],+          inpL "water" [Cint 1],+          outL "ok" [Cint 15],+          inpL "water" [Cint 1],+          outL "ok" [Cint 16],+          outL "coffee" [],+          GateValue δ [],+          GateValue δ []+          ]+    let checkExample = go 0 0 exampleObserved+    assertEqual ("expected conformal trace like " <> show exampleObserved <> ", got " <> show observed) checkObserved checkExample+    assertEqual "expected pass " Pass verdict+    where+    inpL g vals = GateValue (In (InputAttempt(g, True))) vals+    outL g vals = GateValue (Out (OutSusp g)) vals+    go ds waterlevel [] = (ds, waterlevel)+    go ds waterlevel (GateValue (Out Quiescence) []:os) = go (ds+1) waterlevel os+    go ds waterlevel gv@(GateValue x y:os)+      | x == In (InputAttempt ("water", True))+      , [Cint w] <- y = go ds (waterlevel+w) os+      | x == Out (OutSusp "ok")+      , [Cint w] <- y+      , w == waterlevel = go ds waterlevel os+      | x == Out (OutSusp "coffee")+      , [] <- y+      , waterlevel > 15 = go ds waterlevel os+      | otherwise = error $ "wrong gatevalue: " <> show gv++pvarf :: Variable+pvarf = (Variable "p" FloatType)+xvarf :: Variable+xvarf = (Variable "x" FloatType)++stsExampleInitAssignFloat :: Valuation+stsExampleInitAssignFloat = fromConstantsMap $ Map.singleton xvarf (Cfloat (0.0 :: Double))++stsExampleFloat :: IOSTS FreeLattice Integer String String+stsExampleFloat =+    let p = sVar pvarf :: Expr Double+        x = sVar xvarf :: Expr Double+        water = SymInteract (In "water") [pvarf]+        ok = SymInteract (Out "ok") [pvarf]+        coffee = SymInteract (Out "coffee") []+        waterGuard = 1 .<= p .&& p .<= 10+        waterAssign = assignment [xvarf =: x .+ p]+        okGuard = x .== p+        coffeeGuard = x .>= sConst (14.5 :: Double)+        initConf = disjunction [0] :: FreeLattice Integer+        switches = \case+            0 -> Map.fromList [(water,   disjunction [(stsTLoc waterGuard waterAssign, 1)]),+                                (coffee, disjunction [(stsTLoc coffeeGuard noAssignment, 2)])]+            1 -> Map.fromList [(ok,      disjunction [(stsTLoc okGuard noAssignment, 0)])]+            2 -> Map.empty+    in automaton initConf (Set.fromList [water,ok,coffee]) switches+stsExampleIntrprFloat :: STSIntrp FreeLattice Integer (IOAct String String)+stsExampleIntrprFloat = interpretSTS stsExampleFloat stsExampleInitAssignFloat++getSTSIntrpStateFloat :: Integer -> Double -> FreeLattice (IntrpState Integer)+getSTSIntrpStateFloat loc val = disjunction [IntrpState loc $ fromConstantsMap $ Map.singleton (Variable "x" FloatType) (Cfloat val)]++testSTSHappyFlowFloat :: Test+testSTSHappyFlowFloat = TestCase $ do+    -- assertEqual "\ninitial state " (getSTSIntrpStateFloat 0 0.0) (stateConf stsExampleIntrpr)+    let intrp2 = after stsExampleIntrprFloat (GateValue (In "water") [Cfloat (7.5 :: Double)])+    assertEqual "after water 7.5: " (getSTSIntrpStateFloat 1 (7.5 :: Double)) (stateConf intrp2)+    -- let intrp3 = after intrp2 (GateValue (Out "ok") [Cfloat 7.5])+    -- assertEqual "after ok 7.5: " (getSTSIntrpStateFloat 0 (7.5 :: Double)) (stateConf intrp3)+    -- let intrp4 = after intrp3 (GateValue (In "water") [Cfloat 8.5])+    -- assertEqual "after water 8.5: " (getSTSIntrpStateFloat 1 (16.0 :: Double)) (stateConf intrp4)+    -- let intrp5 = after intrp4 (GateValue (Out "ok") [Cfloat 16.0])+    -- assertEqual "after ok 16.0: " (getSTSIntrpStateFloat 0 (16.0 :: Double)) (stateConf intrp5)+    -- let intrp6 = after intrp5 (GateValue (Out "coffee") [])+    -- assertEqual "after coffee: " (getSTSIntrpStateFloat 2 (16.0 :: Double)) (stateConf intrp6)+    return()+++stsExample2 :: (IOSTS FreeLattice Integer String String, IOSTS FreeLattice Integer String String)+stsExample2 =+    let p = sVar pvar :: Expr Integer+        x = sVar xvar :: Expr Integer+        water = SymInteract (In "water") [pvar]+        ok = SymInteract (Out "ok") [pvar]+        coffee = SymInteract (Out "coffee") []+        waterGuard = 1 .<= p .&& p .<= 4+        waterGuard1 = 4 .<= p .&& p .<= 10+        waterAssign = assignment [xvar =: x .+ p]+        okGuard = x .== p+        coffeeGuard = x .>= 15+        initConf = atom 0+        switches = \q -> case q of+            0 -> Map.fromList [(water, atom (stsTLoc waterGuard waterAssign, 1) /\ atom (stsTLoc waterGuard1 waterAssign, 2) )]+            1 -> Map.fromList [(ok, atom (stsTLoc okGuard noAssignment, 0))]+            2 -> Map.fromList [(ok, atom (stsTLoc okGuard noAssignment, 0))]+        initConf2 = atom 0 /\ atom 2+        switches2 = \q -> case q of+            0 -> Map.fromList [(water, atom (stsTLoc waterGuard waterAssign, 1))]+            1 -> Map.fromList [(ok, atom (stsTLoc okGuard noAssignment, 0))]+            2 -> Map.fromList [(water, atom (stsTLoc waterGuard1 waterAssign, 3))]+            3 -> Map.fromList [(ok, atom (stsTLoc okGuard noAssignment, 2))]+    in (automaton initConf (Set.fromList [water,ok,coffee]) switches, automaton initConf2 (Set.fromList [water,ok,coffee]) switches2)++stsExampleIntrpr2a :: STSIntrp FreeLattice Integer (IOAct String String)+stsExampleIntrpr2a = interpretSTS (fst stsExample2) stsExampleInitAssign++stsExampleIntrpr2b :: STSIntrp FreeLattice Integer (IOAct String String)+stsExampleIntrpr2b = interpretSTS (snd stsExample2) stsExampleInitAssign++getSTSValuation :: Integer -> Valuation+getSTSValuation val = fromConstantsMap $ Map.singleton (Variable "x" IntType) (Cint val)++getSTSIntrpState2 :: Integer ->  Integer -> FreeLattice (IntrpState Integer)+getSTSIntrpState2 loc val = atom (IntrpState loc $ getSTSValuation val)++testLatticeCoffeeSTS :: Test+testLatticeCoffeeSTS = TestCase $ do+     assertEqual "\ninitial state " (getSTSIntrpState2 0 0) (stateConf stsExampleIntrpr2a)+     assertEqual "\ninitial state " (getSTSIntrpState2 0 0 /\ getSTSIntrpState2 2 0) (stateConf stsExampleIntrpr2b)+     let intrp2a = after stsExampleIntrpr2a (GateValue (In "water") [Cint 3])+     assertEqual "2a after water 3: " (getSTSIntrpState2 1 3) (stateConf intrp2a)+     let intrp2b = after stsExampleIntrpr2b (GateValue (In "water") [Cint 3])+     assertEqual "2b after water 3: " (getSTSIntrpState2 1 3) (stateConf intrp2b)+     let intrp3a = after intrp2a (GateValue (Out "ok") [Cint 3])+     assertEqual "2a after ok 3: " (getSTSIntrpState2 0 3) (stateConf intrp3a)+     let intrp3b = after intrp2b (GateValue (Out "ok") [Cint 3])+     assertEqual "2b after ok 3: " (getSTSIntrpState2 0 3) (stateConf intrp3b)+     let intrp4a = after intrp3a (GateValue (In "water") [Cint 4])+     assertEqual "2a after water 4: " (getSTSIntrpState2 1 7 /\ getSTSIntrpState2 2 7) (stateConf intrp4a)+     let intrp4b = after intrp3b (GateValue (In "water") [Cint 4])+     assertEqual "2b after water 4: "  (getSTSIntrpState2 1 7) (stateConf intrp4b)+     let intrp5a = after intrp4a (GateValue (Out "ok") [Cint 7])+     assertEqual "2a after ok 7: " (getSTSIntrpState2 0 7) (stateConf intrp5a)+     let intrp5b = after intrp4b (GateValue (Out "ok") [Cint 7])+     assertEqual "2b after ok 7: " (getSTSIntrpState2 0 7) (stateConf intrp5b)+     let intrp6a = after intrp5a (GateValue (In "water") [Cint 5])+     assertEqual "2a after water 5: " (getSTSIntrpState2 2 12) (stateConf intrp6a)+     let intrp6b = after intrp5b (GateValue (In "water") [Cint 5])+     assertEqual "2b after water 5: " underspecified (stateConf intrp6b)+++{- specification:+                        end(p,q)    +                       〚p+q=x+2〛   +                     ╱——————>•————\+    x:=0            ╱              \+    ———>•—————————>•    end(p,q)    ———>•+         start(p)   ╲   〚p-q=x〛    /!done+         〚1<p<3〛     ╲——————>•————/+          x ≔ p                 +                                    +  parameterized by+  * whether start and end gates are input or output+  * the type of branching from the second state (conjunction or disjunction)+  * whether to split the second state into two, where the branching occurs on the first transition (with equal guards) instead of the second+-}+specParameterized :: (String -> IOAct String String) -> (String -> IOAct String String) -> (forall a.FreeLatticeSlow a -> FreeLatticeSlow a -> FreeLatticeSlow a) -> Bool -> IOSTS FreeLatticeSlow Integer String String+specParameterized startType endType comp splitFirst =+    let p = sVar pvar :: Expr Integer+        q = sVar qvar :: Expr Integer+        x = sVar xvar :: Expr Integer+        start = SymInteract (startType "start") [pvar]+        end = SymInteract (endType "end") [pvar, qvar]+        done = SymInteract (Out "done") []+        initConf = pure 0 :: FreeLatticeSlow Integer+        guardStart = 1 .< p .&& p .< 3+        guardEnd1 = p .+ q .== x .+ 2+        guardEnd2 = p .- q .== x+        assignX = assignment [xvar =: p]+        switches =+            if splitFirst+                then \s -> case s of+                        0 -> Map.fromList [(start, pure (stsTLoc guardStart assignX, 1) `comp` pure (stsTLoc guardStart assignX, 2))]+                        1 -> Map.fromList [(end, pure (stsTLoc guardEnd1 noAssignment, 3))]+                        2 -> Map.fromList [(end, pure (stsTLoc guardEnd2 noAssignment, 4))]+                        3 -> Map.fromList [(done, pure (stsTLoc sTrue noAssignment, 5))]+                        4 -> Map.fromList [(done, pure (stsTLoc sTrue noAssignment, 5))]+                        5 -> Map.empty+                else \s -> case s of+                        0 -> Map.fromList [(start, pure (stsTLoc guardStart assignX, 1))]+                        1 -> Map.fromList [(end, pure (stsTLoc guardEnd1 noAssignment, 2) `comp` pure (stsTLoc guardEnd2 noAssignment, 3))]+                        2 -> Map.fromList [(done, pure (stsTLoc sTrue noAssignment, 4))]+                        3 -> Map.fromList [(done, pure (stsTLoc sTrue noAssignment, 4))]+                        4 -> Map.empty+    in automaton initConf (Set.fromList [start, end, done]) switches++{- implementation:+          start(p)   end(p,q)    !done+    ———>•—————————>•—————————>•—————————>•+  parameterized by+  * whether start and end gates are input or output+  * p and q (note, this means that only s specific, single concrete transition start(p) and single concrete transition end(p,q) is defined)+-}+t1 :: (Ord i, Ord o, Num a1, Num a2, IsString t1, IsString t2, IsString o, Eq a1) => (t1 -> IOAct i o) -> (t2 -> IOAct i o) -> Integer -> Integer -> Integer -> a1 -> Map.Map (GateValue (IOAct i o)) a2+t1 startType _ p1 _ _ 0 = Map.fromList $ [((GateValue (startType "start") [Cint p1]), 1)]+t1 _ endType _ p2 q2 1 = Map.fromList $ [((GateValue (endType "end") [Cint p2, Cint q2]), 2)]+t1 _ _ _ _ _ 2 = Map.fromList $ [((GateValue (Out "done") []), 3)]+t1 _ _ _ _ _ 3 = Map.fromList $ []+impParameterized :: (String -> IOAct String String) -> (String -> IOAct String String) -> Integer -> Integer -> Integer -> IO (Adapter.Adapter (SuspendedIFGateValue String String) (Maybe (GateValue String)))+impParameterized startType endType p1 p2 q2 = do+    imp <- pureAdapter (mkStdGen 123) 0.5 (Map.mapKeys gateValueAsIOAct <$> t1 startType endType p1 p2 q2) (0 :: Integer) :: IO (Adapter.Adapter (SuspendedIF (GateValue String) (GateValue String)) (Maybe (GateValue String)))+    Adapter.mapActionsFromSut toIOGateValue imp++testLatticeSTSParameterized' :: String -> Bool -> (forall a. FreeLatticeSlow a -> FreeLatticeSlow a -> FreeLatticeSlow a) -> Bool -> Integer -> Integer -> Integer -> Maybe [SuspendedIFGateValue String String] -> Test+testLatticeSTSParameterized' testName inputThenOut comp splitFirst p1 p2 q2 expectedNonConformalTrace = TestCase $ do+    let (startType, endType, startType', endType') =+            if inputThenOut+                then (In, Out, inp, out)+                else (Out, In, out, inp)+    let nrSteps = 4++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.0 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impParameterized startType endType p1 p2 q2+    let specIntrpr = interpretSTSQuiescentInputAttemptConcrete (specParameterized startType endType comp splitFirst) stsExampleInitAssign+    (verdict, ((observed, _), _)) <- runSMTTester specIntrpr testSelector imp++    case expectedNonConformalTrace of+        Nothing -> do+            assertEqual (testName ++ ": expected Pass after " ++ show observed) Pass verdict+            assertEqual (testName ++ ": expected conformal trace") [+                startType' "start" [Cint p1],+                endType' "end" [Cint p2, Cint q2],+                out "done" [],+                GateValue δ []+                ] observed+        Just t -> do+            assertEqual (testName ++ ": expected Fail after " ++ show observed) Fail verdict+            assertEqual (testName ++ ": expected nonconformal trace") t observed+inp :: i -> [Constant] -> GateValue (IOAct (InputAttempt i) o)+inp g vals = GateValue (In (InputAttempt(g, True))) vals+inpf :: i -> [Constant] -> GateValue (IOAct (InputAttempt i) o)+inpf g vals = GateValue (In (InputAttempt(g, False))) vals+out :: o -> [Constant] -> GateValue (IOAct i (Suspended o))+out g vals = GateValue (Out (OutSusp g)) vals++testLatticeSTSParameterized :: String -> Bool -> (forall a. FreeLatticeSlow a -> FreeLatticeSlow a -> FreeLatticeSlow a) -> Integer -> Integer -> Integer -> Maybe [SuspendedIFGateValue String String] -> [Test]+testLatticeSTSParameterized testName inputThenOut comp p1 p2 q2 expectedNonConformalTrace = [+    testLatticeSTSParameterized' testName          inputThenOut comp False p1 p2 q2 expectedNonConformalTrace,+    testLatticeSTSParameterized' (testName ++ "'") inputThenOut comp True  p1 p2 q2 expectedNonConformalTrace+    ]++testLatticeSTS :: [Test]+testLatticeSTS = concat [+    -- TODO add some cases for quiescence, immediate wrong input failure values, etc.+    testLatticeSTSParameterized "a1" inputThenOutput (\/) 2 2 2 Nothing, -- pass: output (2,2) satisfies the first guard+    testLatticeSTSParameterized "a2" inputThenOutput (\/) 2 4 2 Nothing, -- pass: output (4,2) satisfies the second guard+    testLatticeSTSParameterized "a3" inputThenOutput (\/) 2 3 1 Nothing, -- pass: output (3,1) satisfies both guards+    testLatticeSTSParameterized "a4" inputThenOutput (\/) 2 4 4 (Just [inp "start" [Cint 2], out "end" [Cint 4, Cint 4]]), -- fail: output (4,4) satisfies neither guard+    testLatticeSTSParameterized "a5" inputThenOutput (/\) 2 2 2 (Just [inp "start" [Cint 2], out "end" [Cint 2, Cint 2]]), -- fail: output (2,2) satisfies the first guards, but not both+    testLatticeSTSParameterized "a6" inputThenOutput (/\) 2 4 2 (Just [inp "start" [Cint 2], out "end" [Cint 4, Cint 2]]), -- fail: output (4,2) satisfies the second guards, but not both+    testLatticeSTSParameterized "a7" inputThenOutput (/\) 2 4 4 (Just [inp "start" [Cint 2], out "end" [Cint 4, Cint 4]]), -- fail: output (4,4) satisfies neither guard+    testLatticeSTSParameterized "a8" inputThenOutput (/\) 2 3 1 Nothing, -- pass: output (3,1) satisfies both guards++    testLatticeSTSParameterized "b1" outputThenInput (\/) 2 3 1 Nothing, -- pass: (3,1) is the only input that matches both guards, so is the only specified input overall, thus will be tested and observed+    testLatticeSTSParameterized "b2" outputThenInput (\/) 2 5 5 (Just [out "start" [Cint 2], inpf "end" [Cint 3, Cint 1]]) -- pass: (3,1) is the only input that matches both guards, so is the only specified input overall, thus will be tested but refused+     -- FIXME the next tests are actually unsound: it will pass under the assumption that the test selection (SMT solver) will pick the last two number parameters as input,+     -- but if not, the test case will incorrectly fail. To fix this, change the implementation to accept any (p,q) satisfying any of the guards 〚p+q=4〛 or 〚p-q=2〛+    --testLatticeSTSParameterized "b3" outputThenInput (/\) 2 0 (-2) Nothing, -- pass: (0,-2) is an input that matches one of the guards, so is specified, thus may be tested and in that case will be observed+    --testLatticeSTSParameterized "b4" outputThenInput (/\) 2 5 5 (Just [out "start" [Cint 2], inpf "end" [Cint 0, Cint (-2)]]) -- fail: the tester will pick an input that matches one of the guards, but will be rejected by the implementation+    ]+    where+    inputThenOutput = True+    outputThenInput = False++ {- specification:++    x:=0                               +    ———>•—————————>•———————————>•      +        ?start(p)    !end(p,q)         +         〚1<p<3〛    〚p+q=p+q+x〛        +          x ≔ p                        +                                       +    note, the guard of the second transition is not satisfiable so the second state is quiescent+-}+specQ :: IOSTS FreeLatticeSlow Integer String String+specQ =+    let p = sVar pvar :: Expr Integer+        q = sVar qvar :: Expr Integer+        x = sVar xvar :: Expr Integer+        start = SymInteract (In "start") [pvar]+        end = SymInteract (Out "end") [pvar, qvar]+        initConf = pure 0 :: FreeLatticeSlow Integer+        guardStart = 1 .< p .&& p .< 3+        guardEnd = p .+ q .== p .+ q .+ x+        assignX = assignment [xvar =: p]+        switches = \s -> case s of+                        0 -> Map.fromList [(start, pure (stsTLoc guardStart assignX, 1))]+                        1 -> Map.fromList [(end, pure (stsTLoc guardEnd noAssignment, 2))]+                        2 -> Map.empty+    in automaton initConf (Set.fromList [start, end]) switches++{- implementation:+          start(p)+    ———>•—————————>•+  parameterized by+  * whether start gate is input or output+  * p+-}+tq :: (Ord g, IsString t, Num a1, Num a2, Eq a1) => (t -> g) -> Integer -> a1 -> Map.Map (GateValue g) a2+tq startType p 0 = Map.fromList $ [((GateValue (startType "start") [Cint p]), 1)]+tq _ _ 1 = Map.fromList $ []+impQParameterized :: (String -> IOAct String String) -> Integer -> IO (Adapter.Adapter (SuspendedIFGateValue String String) (Maybe (GateValue String)))+impQParameterized startType p = do+    imp <- pureAdapter (mkStdGen 123) 0.5 (Map.mapKeys gateValueAsIOAct <$> tq startType p) (0 :: Integer) :: IO (Adapter.Adapter (SuspendedIF (GateValue String) (GateValue String)) (Maybe (GateValue String)))+    Adapter.mapActionsFromSut toIOGateValue imp++testLatticeSTSQuiescentPass :: String -> Bool -> Test+testLatticeSTSQuiescentPass testName _ = TestCase $ do+    let nrSteps = 2++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.0 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impQParameterized In 2+    let specIntrpr = interpretSTSQuiescentInputAttemptConcrete specQ stsExampleInitAssign+    (verdict, ((observed, _), _)) <- runSMTTester specIntrpr testSelector imp+    +    assertEqual (testName ++ ": expected Pass after " ++ show observed) Pass verdict+    assertEqual (testName ++ ": expected conformal trace") [+                inp "start" [Cint 2],+                GateValue δ []+                ] observed++testLatticeSTSQuiescentFail1 :: String -> Bool -> Test+testLatticeSTSQuiescentFail1 testName splitFirst = TestCase $ do+    let nrSteps = 2++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.0 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impQParameterized In 2+    let specIntrpr = interpretSTSQuiescentInputAttemptConcrete (specParameterized In Out (\/) splitFirst) stsExampleInitAssign+    (verdict, ((observed, _), _)) <- runSMTTester specIntrpr testSelector imp+    +    assertEqual (testName ++ ": expected Pass after " ++ show observed) Fail verdict+    assertEqual (testName ++ ": expected nonconformal trace") [+                inp "start" [Cint 2],+                GateValue δ []+                ] observed++testLatticeSTSQuiescentFail2 :: String -> Bool -> Test+testLatticeSTSQuiescentFail2 testName _ = TestCase $ do+    let nrSteps = 2++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.0 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impParameterized In Out 2 42 42+    let specIntrpr = interpretSTSQuiescentInputAttemptConcrete specQ stsExampleInitAssign+    (verdict, ((observed, _), _)) <- runSMTTester specIntrpr testSelector imp+    +    assertEqual (testName ++ ": expected Pass after " ++ show observed) Fail verdict+    assertEqual (testName ++ ": expected nonconformal trace") [+                inp "start" [Cint 2],+                out "end" [Cint 42, Cint 42]+                ] observed+++ {- specification:+                       !end(p,q) +                       〚p+q=x+2〛       +                     ╱——————————\      +    x:=0            ╱            \     +    ———>•—————————>• ) !end(p,q)  ———>•+        ?start(p)   ╲   〚p+q=x〛  /     +         〚1<p<3〛     ╲——————————/      +          x ≔ p                        +                                       +  parameterized by whether to split the second state into two, where the branching occurs on the first transition (with equal guards) instead of the second+-}+specUnimplementableParameterized :: Bool -> IOSTS FreeLatticeSlow Integer String String+specUnimplementableParameterized splitFirst =+    let p = sVar pvar :: Expr Integer+        q = sVar qvar :: Expr Integer+        x = sVar xvar :: Expr Integer+        start = SymInteract (In "start") [pvar]+        end = SymInteract (Out "end") [pvar, qvar]+        initConf = pure 0 :: FreeLatticeSlow Integer+        guardStart = 1 .< p .&& p .< 3+        guardEnd1 = p .+ q .== x .+ 2+        guardEnd2 = p .+ q .== x+        assignX = assignment [xvar =: p]+        switches =+            if splitFirst+                then \s -> case s of+                        0 -> Map.fromList [(start, pure (stsTLoc guardStart assignX, 1) /\ pure (stsTLoc guardStart assignX, 2))]+                        1 -> Map.fromList [(end, pure (stsTLoc guardEnd1 noAssignment, 3))]+                        2 -> Map.fromList [(end, pure (stsTLoc guardEnd2 noAssignment, 3))]+                        3 -> Map.empty+                else \s -> case s of+                        0 -> Map.fromList [(start, pure (stsTLoc guardStart assignX, 1))]+                        1 -> Map.fromList [(end, pure (stsTLoc guardEnd1 noAssignment, 2) /\ pure (stsTLoc guardEnd2 noAssignment, 3))]+                        2 -> Map.empty+                        3 -> Map.empty+    in automaton initConf (Set.fromList [start, end]) switches++testLatticeSTSUnimplementable :: String -> Bool -> Test+testLatticeSTSUnimplementable testName splitFirst = TestCase $ do+    let nrSteps = 2++    let testSelector = randomDataOrWaitForOutputTestSelectorFromSeed 456 0.0 `untilCondition` stopAfterSteps nrSteps+                `observingOnly` traceObserver `andObserving` stateObserver `andObserving` inconclusiveStateObserver+    imp <- impQParameterized In 2+    let specIntrpr = interpretSTSQuiescentInputAttemptConcrete (specUnimplementableParameterized splitFirst) stsExampleInitAssign+    (verdict, ((observed, _), _)) <- runSMTTester specIntrpr testSelector imp+    +    assertEqual (testName ++ ": expected Fail after " ++ show observed) Fail verdict+    assertEqual (testName ++ ": expected nonconformal trace") [+                inp "start" [Cint 2],+                GateValue δ []+                ] observed++testLatticeSTSQuiescence :: [Test]+testLatticeSTSQuiescence = [+    testLatticeSTSQuiescentPass "q1" True, -- a quiescent implementation and STS will lead to a pass+    testLatticeSTSQuiescentPass "q2'" False, -- a quiescent implementation and STS will lead to a pass+    testLatticeSTSQuiescentFail1 "q3" True, -- a quiescent implementation will fail against a non-quiescent specification+    testLatticeSTSQuiescentFail1 "q4" False, -- a quiescent implementation will fail against a non-quiescent specification+    testLatticeSTSQuiescentFail2 "q3" True, -- a non-quiescent implementation will fail against a quiescent specification+    testLatticeSTSQuiescentFail2 "q4" False, -- a non-quiescent implementation will fail against a quiescent specification+    testLatticeSTSUnimplementable "u1" True, -- an unimplementable specification (two conjunctive conditions contradicting eachother) is not implemented by a quiescent implementation+    testLatticeSTSUnimplementable "u2'" False -- an unimplementable specification (two conjunctive conditions contradicting eachother) is not implemented by a quiescent implementation+    ]
+ test/Test/Lattest/Model/StandardAutomata.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Lattest.Model.StandardAutomata (+IF(..),+OF(..),+StateF(..),+sf,+IG(..),+OG(..),+sg,+testSpecF,+testPrintSpecF,+testSpecG,+testSpecGQuiescent,+testExponentialNonDeterminism+)+where++import Prelude hiding (take)+import Test.HUnit+import qualified Text.RawString.QQ as QQ++import Lattest.Model.Automaton(AutSyntax, after, afters, stateConf, automaton, prettyPrint)+import Lattest.Model.StandardAutomata(interpretConcrete, interpretQuiescentConcrete, nonDetConcTransFromMRel)+import Lattest.Model.Alphabet(IOAct(..), asSuspended, δ)+import Lattest.Model.BoundedMonad((/\), (\/), atom, top, bot)+import qualified Lattest.Model.BoundedMonad as BM (FreeLattice(..), disjunction)+import qualified Data.Map as Map (Map)+import qualified Data.Set as Set++data IF = A | B deriving (Show, Eq, Ord)+data OF = X | Y deriving (Show, Eq, Ord)+data StateF = Q0f | Q1f | Q2f deriving (Show, Eq, Ord)+x :: IOAct i OF+x = Out X+y :: IOAct i OF+y = Out Y+af :: IOAct IF o+af = In A+bf :: IOAct IF o+bf = In B+q0f :: BM.FreeLattice StateF+q0f = atom Q0f+q1f :: BM.FreeLattice StateF+q1f = atom Q1f+q2f :: BM.FreeLattice StateF+q2f = atom Q2f+menuf :: [IOAct IF OF]+menuf = [af, bf, x, y]+tf :: StateF -> Map.Map (IOAct IF OF) (BM.FreeLattice ((), StateF))+tf = nonDetConcTransFromMRel+    [(Q0f, af, q0f /\ (q1f \/ q2f))+    ,(Q0f, x, q0f)+    ,(Q0f, y, q0f)+    ,(Q1f, x, top)+    ,(Q2f, bf, q0f)+    ,(Q2f, y, q2f)+    ]+sf :: AutSyntax BM.FreeLattice StateF (IOAct IF OF) ()+sf = automaton q0f menuf tf++testSpecF :: Test+testSpecF = TestCase $ do+    let rf = interpretConcrete sf+    assertEqual "sf after ?A !X" q0f (stateConf $ rf `after` af `after` x)+    assertEqual "sf after ?A !Y" (q0f /\ q2f) (stateConf $ rf `after` af `after` y)+    assertEqual "sf after ?A !A" (q0f /\ (q1f \/ q2f)) (stateConf $ rf `after` af `after` af)+    assertEqual "sf after ?A !B" top (stateConf $ rf `after` af `after` bf)++testPrintSpecF :: Test+testPrintSpecF = TestCase $ assertBool failureMessage (expected == actual) -- no assertEquals to avoid printing the unreadable ascii-escaped variant of the tested unicode strings +    where+    failureMessage = "print of sf does not match, expected:" ++ expected ++ "but received:" ++ actual+    actual = "\n" ++ prettyPrint sf ++ "\n" -- newlines before and after to match those of the "expected" below.+    -- fancy quasiquotes to allow direct copy-pasting of the printed expected string into the source code below. With newline at start and end for readability.+    expected = [QQ.r|+initial location configuration: Q0f+locations: Q0f, Q1f, Q2f+transitions:+Q0f  ――?A⟶  ((),Q0f) ∧ (((),Q1f) ∨ ((),Q2f))+Q0f  ――?B⟶  ⊤+Q0f  ――!X⟶  ((),Q0f)+Q0f  ――!Y⟶  ((),Q0f)+Q1f  ――?A⟶  ⊤+Q1f  ――?B⟶  ⊤+Q1f  ――!X⟶  ⊤+Q1f  ――!Y⟶  ⊥+Q2f  ――?A⟶  ⊤+Q2f  ――?B⟶  ((),Q0f)+Q2f  ――!X⟶  ⊥+Q2f  ――!Y⟶  ((),Q2f)+|]++data IG = A2 | B2 | On | Take deriving (Show, Eq, Ord)+data OG = C | T | CM | TM deriving (Show, Eq, Ord)+data StateG = Q0g | Q1g | Q2g | Q3g | Q4g | Q5g | Q6g | Q7g | Q8g | Q9g | Q10g deriving (Show, Eq, Ord)++c :: IOAct i OG+c = Out C+t :: IOAct i OG+t = Out T+cm :: IOAct i OG+cm = Out CM+tm :: IOAct i OG+tm = Out TM+ag :: IOAct IG o+ag = In A2+bg :: IOAct IG o+bg = In B2+on :: IOAct IG o+on = In On+take :: IOAct IG o+take = In Take+menug :: [IOAct IG OG]+menug = [c, t, cm, tm, ag, bg, on, take]++q0g :: BM.FreeLattice StateG+q0g = atom Q0g+q1g :: BM.FreeLattice StateG+q1g = atom Q1g+q2g :: BM.FreeLattice StateG+q2g = atom Q2g+q3g :: BM.FreeLattice StateG+q3g = atom Q3g+q4g :: BM.FreeLattice StateG+q4g = atom Q4g+q5g :: BM.FreeLattice StateG+q5g = atom Q5g+q6g :: BM.FreeLattice StateG+q6g = atom Q6g+q7g :: BM.FreeLattice StateG+q7g = atom Q7g+q8g :: BM.FreeLattice StateG+q8g = atom Q8g+q9g :: BM.FreeLattice StateG+q9g = atom Q9g+q10g :: BM.FreeLattice StateG+q10g = atom Q10g++tg :: StateG -> Map.Map (IOAct IG OG) (BM.FreeLattice ((), StateG))+tg = nonDetConcTransFromMRel+    [(Q0g, on, q1g /\ q3g /\ q5g /\ q8g)+    ,(Q1g, ag, q2g)+    ,(Q2g, c,  top)+    ,(Q3g, bg, q4g)+    ,(Q4g, t,  top)+    ,(Q4g, tm, top)+    ,(Q5g, bg, q6g \/ q7g)+    ,(Q6g, cm, top)+    ,(Q7g, tm, top)+    ,(Q8g, ag, q9g)+    ,(Q8g, bg, q9g)+    ,(Q9g, c,  q10g)+    ,(Q9g, t,  q10g)+    ,(Q9g, cm, q10g)+    ,(Q9g, tm, q10g)+    ,(Q10g, take, q1g /\ q3g /\ q5g /\ q8g)+    ]+sg :: AutSyntax BM.FreeLattice StateG (IOAct IG OG) ()+sg = automaton q0g menug tg++testSpecG :: Test+testSpecG = TestCase $ do+    let rg = interpretConcrete sg+    assertEqual "sg after ?On ?B !T" bot (stateConf $ rg `after` on `after` bg `after` t)+    assertEqual "sg after ?On ?B !TM" q10g (stateConf $ rg `after` on `after` bg `after` tm)++testSpecGQuiescent :: Test+testSpecGQuiescent = TestCase $ do+    let rg = interpretQuiescentConcrete sg+    assertEqual "Δ(sg) after δ ?On δ ?B !T" bot (stateConf $ rg `afters` [δ, asSuspended on, δ, asSuspended bg, asSuspended t])+    assertEqual "Δ(sg) after δ ?On δ ?B δ" bot (stateConf $ rg `afters` [δ, asSuspended on, δ, asSuspended bg, δ])+    assertEqual "Δ(sg) after δ ?On δ ?B !TM" q10g (stateConf $ rg `afters` [δ, asSuspended on, δ, asSuspended bg, asSuspended tm])+    assertEqual "Δ(sg) after δ ?On δ ?B δ" bot (stateConf $ rg `afters` [δ, asSuspended on, δ, asSuspended bg, δ])++sDoubleState :: BM.FreeLattice Integer+sDoubleState = BM.disjunction [0 :: Integer, 1]+tDoubleRecursion :: Integer -> Map.Map String (BM.FreeLattice ((), Integer))+tDoubleRecursion = nonDetConcTransFromMRel+    [(0, "act", sDoubleState)+    ,(1, "act", sDoubleState)+    ]+sDoubleRecursion :: AutSyntax BM.FreeLattice Integer String ()+sDoubleRecursion = automaton sDoubleState ["act"] tDoubleRecursion++testExponentialNonDeterminism :: Test+testExponentialNonDeterminism = TestCase $ do+    -- take 1000 steps, each 'duplicating' the state configuration. With deduplication, the state configuration should still have size 2+    let doubleRecursion = interpretConcrete sDoubleRecursion+        BM.FreeLattice conf = stateConf $ doubleRecursion `afters` replicate 1000 "act"+        nrStatesAfterBlowup = Set.size . Set.unions $ conf+    assertEqual ("only 2 states in automaton but found " ++ show nrStatesAfterBlowup ++ " in state configuration") 2 nrStatesAfterBlowup+
+ test/Test/Lattest/Model/Symbolic/Expr.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Lattest.Model.Symbolic.Expr (+prop_evalSymbolic,+PropEvalSymbolic,+prop_solveSymbolic,+evalTests,+solveTests+)+where++import Lattest.Model.Symbolic.Internal.FreeMonoidX as FM+import Lattest.Model.Symbolic.Expr+import Lattest.Model.Symbolic.Internal.ExprDefs(Expr(Expr))+import Lattest.Model.Symbolic.SolveSymPrim+import qualified Lattest.SMT as SMT+import qualified Data.List as List++import qualified Data.Set as Set+import qualified Debug.Trace as Trace+import qualified Control.Monad as CM+import Test.HUnit+import Test.QuickCheck+import Test.QuickCheck.Monadic++instance (Arbitrary a, ConcreteGenExpr a) => Arbitrary (Expr a) where+    arbitrary = Expr <$> arbitrary -- max to avoid large expressions, which will choke the SMT solver+    -- for debugging exponential blowups in Arbitrary generation+    -- arbitrary = ((\e -> Trace.trace ("size " ++ (show $ sizeOf e) ++ " | ") e). Expr) <$> arbitrary+    -- arbitrary = ((\e -> Trace.trace ("expr " ++ show e ++ " | ") e). Expr) <$> arbitrary+    shrink (view -> e) = Expr <$> shrink e++sizeOf :: SizeOf a => Expr a -> Int+sizeOf = sizeOf' . view++sizeOf' :: SizeOf a => ExprView a -> Int+sizeOf' (Var _) = 1+sizeOf' (Const c) = sizeOfTyped c+sizeOf' (Ite i t e) = sizeOf' i + sizeOf' t + sizeOf' e + 1+sizeOf' (EqualInt e1 e2) = sizeOf' e1 + sizeOf' e2 + 1+sizeOf' (EqualBool e1 e2) = sizeOf' e1 + sizeOf' e2 + 1+sizeOf' (EqualString e1 e2) = sizeOf' e1 + sizeOf' e2 + 1+sizeOf' (Divide e1 e2) = sizeOf' e1 + sizeOf' e2 + 1+sizeOf' (Modulo e1 e2) = sizeOf' e1 + sizeOf' e2 + 1+sizeOf' (Sum es) = foldrTerms (\a b -> sizeOf' a + b) 0 es + 1+sizeOf' (Product es) = foldrTerms (\a b -> sizeOf' a + b) 0 es + 1+sizeOf' (Length e) = sizeOf' e + 1+sizeOf' (GezInt e) = sizeOf' e + 1+sizeOf' (Not e) = sizeOf' e + 1+sizeOf' (And es) = (sum $ sizeOf' <$> Set.toList es) + 1+sizeOf' (Concat es) = (sum $ sizeOf' <$> es) + 1++class SizeOf t+    where+    sizeOfTyped :: t -> Int++instance SizeOf Integer+    where+    sizeOfTyped _ = 1++instance SizeOf Bool+    where+    sizeOfTyped _ = 1++instance SizeOf String+    where+    sizeOfTyped s = length s++instance (Arbitrary a, ConcreteGenExpr a) => Arbitrary (ExprView a) where+    arbitrary = sized genExpr+    shrink (Var _) = []+    shrink (Const c) = Const <$> shrinkConst c+    shrink (Ite i t e) = [Ite i' t' e' | (i', t', e') <- shrink (i, t, e)] ++ shrink t ++ shrink e+    shrink (EqualInt e1 e2) = [EqualInt e1' e2' | (e1', e2') <- shrink (e1, e2) ] ++ [Const True, Const False]+    shrink (EqualBool e1 e2) = [EqualBool e1' e2' | (e1', e2') <- shrink (e1, e2) ] ++ [Const True, Const False]+    shrink (EqualString e1 e2) = [EqualString e1' e2' | (e1', e2') <- shrink (e1, e2) ] ++ [Const True, Const False]+    shrink (Divide e1 e2) = [Divide e1' e2' | (e1', e2') <- shrink (e1, e2) ] ++ shrink e1+    shrink (Modulo e1 e2) = [Modulo e1' e2' | (e1', e2') <- shrink (e1, e2) ] ++ shrink e1 ++ shrink e2+    shrink (Sum _) = [] -- shrinkListExpr (Sum . FM.fromListT) (FM.toListT es)+    shrink (Product _) = [] -- shrinkListExpr (Product . FM.fromListT) (FM.toList es)+    shrink (Length e) = Length <$> shrink e+    shrink (GezInt e) = GezInt <$> shrink e+    shrink (Not e) = [e]+    shrink (And es) = shrinkListExpr (And . Set.fromList) (Set.toList es)+    shrink (Concat es) = Concat <$> shrinkList (const []) es++shrinkListExpr :: Arbitrary t1 => (t1 -> t2) -> t1 -> [t2]+shrinkListExpr op es = fmap op (shrink es)++class ConcreteGenExpr t where+    genExpr :: Int -> Gen (ExprView t)+    shrinkConst :: t -> [t]++instance ConcreteGenExpr Integer where+    genExpr n | n <= 0 = oneof [+        arbitraryVar IntType,+        CM.liftM Const arbitrary+        ]+    genExpr n | n > 0 = oneof [+        arbitraryVar IntType,+        CM.liftM Const arbitrary,+        CM.liftM3 Ite subexpr3 subexpr3 subexpr3,+        CM.liftM2 Divide subexpr2 subexpr2,+        CM.liftM2 Modulo subexpr2 subexpr2,+        CM.liftM Sum (FM.fromListT <$> genList subexpr2),+        CM.liftM Product (FM.fromListT <$> genList subexprSqrt),+        CM.liftM Length subexpr+        ]+        where+        subexpr :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr = genExpr (n - 1)+        subexpr2 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr2 = genExpr $ (n `div` 2) - 1+        subexpr3 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr3 = genExpr $ (n `div` 3) - 1+        subexprSqrt :: ConcreteGenExpr t => Gen (ExprView t)+        subexprSqrt = genExpr (intSqrt n - 1)+    shrinkConst = shrink++instance ConcreteGenExpr Bool where+    genExpr n | n <= 0 = oneof [+        arbitraryVar BoolType,+        CM.liftM Const arbitrary+        ]+    genExpr n | n > 0 = oneof [+        arbitraryVar BoolType,+        CM.liftM Const arbitrary,+        CM.liftM3 Ite subexpr3 subexpr3 subexpr3,+        CM.liftM2 EqualInt subexpr2 subexpr2,+        CM.liftM2 EqualBool subexpr2 subexpr2,+        CM.liftM2 EqualString subexpr2 subexpr2,+        CM.liftM GezInt subexpr,+        CM.liftM Not subexpr,+        CM.liftM And (Set.fromList <$> genList subexprSqrt)+        ]+        where+        subexpr :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr = genExpr (n - 1)+        subexpr2 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr2 = genExpr $ (n `div` 2) - 1+        subexpr3 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr3 = genExpr $ (n `div` 3) - 1+        subexprSqrt :: ConcreteGenExpr t => Gen (ExprView t)+        subexprSqrt = genExpr (intSqrt n - 1)+    shrinkConst = shrink++instance ConcreteGenExpr String where+    genExpr n | n <= 0 = oneof [+        arbitraryVar StringType,+        CM.liftM Const stringExpr+        ]+    genExpr n | n > 0 = oneof [+        arbitraryVar StringType,+        CM.liftM Const stringExpr,+        CM.liftM3 Ite subexpr3 subexpr3 subexpr3,+        CM.liftM Concat (genList subexprSqrt)+        ]+        where+        subexpr2 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr2 = genExpr $ (n `div` 2) - 1+        subexpr3 :: ConcreteGenExpr t => Gen (ExprView t)+        subexpr3 = genExpr $ (n `div` 3) - 1+        subexprSqrt :: ConcreteGenExpr t => Gen (ExprView t)+        subexprSqrt = genExpr (intSqrt n - 1)+    shrinkConst _ = []+    {--- very crude and fast string shrinking. Should suffice while we don't do anything interesting with strings yet+    shrinkConst "" = []+    shrinkConst [c] = [[]]+    shrinkConst xs = [take (length xs `div` 2) xs, drop (length xs `div` 2) xs]+    -}+charExpr :: Gen Char+charExpr = elements $ ['A'..'Z'] ++ ['a'..'z']+stringExpr :: Gen String+stringExpr = CM.liftM2 (++) (return <$> charExpr) (genList charExpr)++-- generate lists, more conservatively than with listOf, in order to avoid exponential blowup+genList :: Gen a -> Gen [a]+genList g = sized $ \n -> do+    _ <- choose (0, intSqrt n - 1)+    CM.replicateM (intSqrt n) g++intSqrt :: Int -> Int+intSqrt = floor . (sqrt :: Double -> Double) . fromIntegral++prop_symbolicEval :: Expr Integer -> Bool+prop_symbolicEval e = rightToMaybe (eval e) == localConcreteEval e+    where+    rightToMaybe (Left _) = Nothing+    rightToMaybe (Right x) = Just x+    localConcreteEval = concreteEval' . view++arbitraryVar :: Type -> Gen (ExprView t)+arbitraryVar t = +    let prefix = case t of+                    IntType -> 'i'+                    BoolType -> 'b'+                    StringType -> 's'+    in CM.liftM (\n -> Var $ Variable (prefix:n) t) (return <$> charExpr)++type PropEvalSymbolic t = Expr t -> Bool++prop_evalSymbolic :: (Eq t, ConcreteEval t) => Expr t -> Bool+prop_evalSymbolic e =+    let l = concreteEval e+        r = symbolicEval e+    --in if l == r then True else Trace.trace ("concrete eval: " ++ show l ++ "\nsymbolic eval: " ++ show r ++ "\n") False+    in l == r++symbolicEval :: Expr t -> Maybe t+symbolicEval = rightToMaybe . eval+    where+    rightToMaybe :: Either a b -> Maybe b+    rightToMaybe (Left _) = Nothing+    rightToMaybe (Right b) = Just b++prop_solveSymbolic :: Expr Bool -> Property+prop_solveSymbolic guard = monadicIO $ do+    mValuation <- run $ SMT.runSMT $ solveGuard (Set.toList $ freeVars guard) guard+    case mValuation of+        Nothing -> return ()+        Just valuation ->+            let val = substConst valuation guard+            in case concreteEval val of+                Nothing -> return () -- we may generate an expression which can have an undefined value, e.g. division by zero, for which the SMT solver may pick an arbitrary valuation+                Just sat -> Trace.trace ("[" ++ show valuation ++ "]" ++ show guard) $ assertWith sat ("Substituting solved value doesn't yield True for [" ++ show valuation ++ "] " ++ show guard)++concreteEval :: ConcreteEval t => Expr t -> Maybe t+concreteEval = concreteEval' . view++class ConcreteEval t where+    concreteEval' :: ExprView t -> Maybe t++instance ConcreteEval Integer where+    concreteEval' (Var _) = Nothing+    concreteEval' (Const c) = Just c+    concreteEval' (Ite i t e) = concreteIfThenElse i t e+    concreteEval' (Divide e1 e2) = concreteBinOpMaybe (safeZero div) e1 e2+    concreteEval' (Modulo e1 e2) = concreteBinOpMaybe (safeZero mod) e1 e2+    concreteEval' (Length e) = concreteUnaryOp (Prelude.toInteger . length) e+    concreteEval' (Sum es) = foldOccurList 0 (+) (*) es+    concreteEval' (Product es) = foldOccurList 1 (*) (^) es++safeZero :: (Integer -> Integer -> Integer) -> (Integer -> Integer -> Maybe Integer)+safeZero _ _ 0 = Nothing+safeZero op n m = Just $ n `op` m++foldOccurList :: TermWrapper t => Integer -> (Integer -> Integer -> Integer) -> (Integer -> Integer -> Integer) -> FreeMonoidX (t (ExprView Integer)) -> Maybe Integer+foldOccurList zero add mult monoid = (foldr add zero) <$> sequence (maybeEvalTerm <$> FM.toOccurListT monoid)+    where+    maybeEvalTerm :: (ExprView Integer, Integer) -> Maybe Integer+    maybeEvalTerm (x, n) = case concreteEval' x of+        Just y -> Just (y `mult` n)+        Nothing -> Nothing+++instance ConcreteEval Bool where+    concreteEval' (Var _) = Nothing+    concreteEval' (Const c) = Just c+    concreteEval' (Ite i t e) = concreteIfThenElse i t e+    concreteEval' (EqualInt e1 e2) = concreteBinOp (==) e1 e2+    concreteEval' (EqualBool e1 e2) = concreteBinOp (==) e1 e2+    concreteEval' (EqualString e1 e2) = concreteBinOp (==) e1 e2+    concreteEval' (GezInt e) = concreteUnaryOp (>= 0) e+    concreteEval' (Not e) = concreteUnaryOp not e+    concreteEval' (And es) = fmap and $ sequence (concreteEval' <$> Set.toList es)++instance ConcreteEval String where+    concreteEval' (Var _) = Nothing+    concreteEval' (Const c) = Just c+    concreteEval' (Ite i t e) = concreteIfThenElse i t e+    concreteEval' (Concat es) = concat <$> (sequence $ concreteEval' <$> es)++concreteUnaryOp :: (ConcreteEval t1) => (t1 -> t2) -> ExprView t1 -> Maybe t2+concreteUnaryOp op e = do+    x <- concreteEval' e+    return $ op x++concreteBinOp :: (ConcreteEval t1, ConcreteEval t2) => (t1 -> t2 -> t3) -> ExprView t1 -> ExprView t2 -> Maybe t3+concreteBinOp binop e1 e2 = do+    x <- concreteEval' e1+    y <- concreteEval' e2+    return $ x `binop` y++concreteBinOpMaybe :: (ConcreteEval t1, ConcreteEval t2) => (t1 -> t2 -> Maybe t3) -> ExprView t1 -> ExprView t2 -> Maybe t3+concreteBinOpMaybe binop e1 e2 = do+    x <- concreteEval' e1+    y <- concreteEval' e2+    x `binop` y++concreteIfThenElse :: (ConcreteEval t) => ExprView Bool -> ExprView t -> ExprView t -> Maybe t+concreteIfThenElse i t e = do+    cond <- concreteEval' i+    if cond+        then concreteEval' t+        else concreteEval' e++evalTests :: [Test]+evalTests = [testEvalEmptyProduct, testEvalNegativeModulo]++solveTests :: [Test]+solveTests = [testSolveNegativeModulo]++testEvalExpression :: (Eq a, Show a, ConcreteEval a) => Expr a -> String -> Test+testEvalExpression e msg = TestCase $ assertEqual msg (concreteEval e) (symbolicEval e)++testEvalEmptyProduct :: Test+testEvalEmptyProduct = testEvalExpression (sProduct @Integer ([])) "empty product evaluation incorrect"++testSolveExpression :: Expr Bool -> Test+testSolveExpression guard = TestCase $ do+    mValuation <- SMT.runSMT $ solveGuard (Set.toList $ freeVars guard) guard+    case mValuation of+        Nothing -> return ()+        Just valuation ->+            let val = substConst valuation guard+            in case concreteEval val of+                Nothing -> return () -- we may generate an expression which can have an undefined value, e.g. division by zero, for which the SMT solver may pick an arbitrary valuation+                --Just sat -> Trace.trace (show valuation) $ assertBool ("Substituting solved value doesn't yield True for [" ++ show valuation ++ "] " ++ show guard) sat+                Just sat -> assertBool ("Substituting solved value doesn't yield True for [" ++ show valuation ++ "] " ++ show guard) sat++testEvalNegativeModulo :: Test+testEvalNegativeModulo = testEvalExpression ((-2) .% (-2)) "negative mod evaluates incorrectly"++testSolveNegativeModulo :: Test+testSolveNegativeModulo = testSolveExpression ((-2) .% (-2) .== sVar (Variable "ix" IntType))+
+ test/Test/Lattest/Util/ModelParsingUtils.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+module Test.Lattest.Util.ModelParsingUtils (+testReadAutFile+)+where++import Prelude hiding (take)+import Test.HUnit+import qualified Data.Set as Set++import Lattest.Util.ModelParsingUtils(readAutFile)+import Lattest.Model.Alphabet(IOAct(..))++expectedTransitions :: [(String, IOAct String String, String)]+expectedTransitions = +    [ ("Idle",         In "coin_i",          "CoinInserted")+    , ("CoinInserted", In "select_coffee_i", "Brewing")+    , ("Brewing",      Out "ready_o",        "Ready")+    , ("Ready",        In "take_cup_i",      "Idle")+    ]++testReadAutFile :: Test+testReadAutFile = TestCase $ do+    let filePath = "./test/Test/Lattest/Util/dummy.aut"+        expectedInAlphabet = Set.fromList ["take_cup_i", "select_coffee_i", "coin_i"]+        expectedOutAlphabet = Set.fromList ["ready_o"]+        expectedStates = Set.fromList ["Idle", "Brewing", "CoinInserted", "Ready"]+++    (inputAlphabet, outputAlphabet, states, initialState, Just transitions) <- readAutFile filePath++    assertEqual "IAlphabet" expectedInAlphabet (Set.fromList inputAlphabet)+    assertEqual "OAlphabet" expectedOutAlphabet (Set.fromList outputAlphabet)+    assertEqual "Expected states" expectedStates states+    assertEqual "Initial state" "Idle" initialState+    assertEqual "Transitions" expectedTransitions transitions
+ test/Test/Lattest/Util/STSJSONParserTest.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE QuasiQuotes #-}++module Test.Lattest.Util.STSJSONParserTest+    ( testSTSJSONParserNominal+    , testSTSJSONParserNominalFloat+    , testSTSJSONParserUnknownType+    , testSTSJSONParserAssignmentTypeMismatch+    , testSTSJSONParserGuardTypeMismatch+    , testSTSJSONParserGateIdDup+    , testSTSJSONParserUnsupportedGuardOperand+    , testSTSJSONParserUnsupportedAssignmentOperand+    , testSTSJSONParserMissingSwitches+    , testSTSJSONParserMissingGates+    , stsJSONParserTests+    ) where++import Data.List (isInfixOf)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Text.RawString.QQ as QQ+import Test.HUnit+import Lattest.Model.Alphabet(IOAct(..), SymInteract(..))+import Lattest.Model.Automaton(alphabet, prettyPrintIntrp)+import Lattest.Model.StandardAutomata(interpretSTS)+import Lattest.Model.Symbolic.Expr(Constant(..), Type(..), Variable(..), fromConstantsMap)+import Lattest.Util.STSJSONParser(stsFromJSONFile)++testDir :: FilePath+testDir = "./test/Test/Lattest/Util/STSJSONExamples/"++-- | Check that the error string contains the expected substring.+assertErrorContains :: String -> String -> Either String a -> Assertion+assertErrorContains label errsubstr (Right _)  =+    assertFailure (label ++ ": expected an error containing '" ++ errsubstr ++ "', but parsing succeeded")+assertErrorContains label errsubstr (Left err) =+    assertBool+        (label ++ ": expected error to contain '" ++ errsubstr ++ "', got: " ++ err)+        (errsubstr `isInfixOf` err)++{-|+Evaluate nominal case with:+- a variety of variable types (Int, String, Bool)+- (some) shortnames for gates+- multiple assignments in a single switch+- multiple switches with the same gate but different guards and assignments+-}+testSTSJSONParserNominal :: Test+testSTSJSONParserNominal = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "nominal_all_types.json")+    case result of+        Left err -> assertFailure ("expected successful parse, got: " ++ err)+        Right (sts, valuation) -> do+            assertEqual "initial valuation"+                (fromConstantsMap $ Map.fromList+                    [ (Variable "counter" IntType,    Cint    5    )+                    , (Variable "label"   StringType, Cstring ""   )+                    , (Variable "active"  BoolType,   Cbool   False)+                    ])+                valuation+            assertEqual "alphabet"+                (Set.fromList+                    [ SymInteract (In  "register")  [Variable "label_p"   StringType]+                    , SymInteract (In  "update")    [Variable "counter_p" IntType   ]+                    , SymInteract (Out "O1")        []+                    , SymInteract (Out "confirm")   [Variable "counter_p" IntType   ]+                    ])+                (alphabet sts)+            assertBool failureMessage (expected == actual)+                where+                intrpsts = interpretSTS sts valuation+                actual   = "\n" ++ prettyPrintIntrp intrpsts ++ "\n"+                failureMessage = "print of STS does not match, expected:" ++ expected ++ "but received:" ++ actual+                expected = [QQ.r|+current state configuration: ("0",{counter:=5,active:=False,label:=""})+initial location configuration: "0"+locations: "0", "1", "2"+transitions:+"0"  ――?"register" [label_p:String]⟶  ⊤+"0"  ――?"update" [counter_p:Int]⟶  (((counter+-4)) ≥ 0, {active:=False},"2") ∧ (¬(((counter+-5)) ≥ 0), {counter:=(counter+counter_p)},"1")+"0"  ――!"O1" []⟶  ⊥+"0"  ――!"confirm" [counter_p:Int]⟶  ⊥+"1"  ――?"register" [label_p:String]⟶  ((label) = (label_p), {counter:=(counter+1), active:=True},"0") ∧ ((active) = (True), {label:=label_p},"0")+"1"  ――?"update" [counter_p:Int]⟶  ⊤+"1"  ――!"O1" []⟶  ⊥+"1"  ――!"confirm" [counter_p:Int]⟶  ⊥+"2"  ――?"register" [label_p:String]⟶  ⊤+"2"  ――?"update" [counter_p:Int]⟶  ⊤+"2"  ――!"O1" []⟶  (True, {},"0")+"2"  ――!"confirm" [counter_p:Int]⟶  ⊥+|]++{-|+Evaluate nominal case with float variables+-}+testSTSJSONParserNominalFloat :: Test+testSTSJSONParserNominalFloat = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "nominal_float_types.json")+    case result of+        Left err -> assertFailure ("expected successful parse, got: " ++ err)+        Right (sts, valuation) -> do+            assertEqual "initial valuation"+                (fromConstantsMap $ Map.fromList+                    [ (Variable "counter" FloatType,  Cfloat  0.0  )+                    , (Variable "label"   StringType, Cstring ""   )+                    , (Variable "active"  BoolType,   Cbool   False)+                    ])+                valuation+            assertEqual "alphabet"+                (Set.fromList+                    [ SymInteract (In  "register")  [Variable "label_p"   StringType]+                    , SymInteract (In  "update")    [Variable "counter_p" FloatType  ]+                    , SymInteract (Out "O1")        []+                    , SymInteract (Out "confirm")   [Variable "counter_p" FloatType  ]+                    ])+                (alphabet sts)+            assertBool failureMessage (expected == actual)+                where+                intrpsts = interpretSTS sts valuation+                actual   = "\n" ++ prettyPrintIntrp intrpsts ++ "\n"+                failureMessage = "print of STS does not match, expected:" ++ expected ++ "but received:" ++ actual+                expected = [QQ.r|+current state configuration: ("0",{active:=False,label:="",counter:=0.0})+initial location configuration: "0"+locations: "0", "1", "2"+transitions:+"0"  ――?"register" [label_p:String]⟶  ⊤+"0"  ――?"update" [counter_p:Float]⟶  (((counter+-5.5)) ≥ 0, {active:=False},"2") ∧ (¬(((counter+-5.5)) ≥ 0), {counter:=(counter+counter_p)},"1")+"0"  ――!"O1" []⟶  ⊥+"0"  ――!"confirm" [counter_p:Float]⟶  ⊥+"1"  ――?"register" [label_p:String]⟶  ((label) = (label_p), {active:=True, counter:=(counter+1.0)},"0") ∧ ((active) = (True), {label:=label_p},"0")+"1"  ――?"update" [counter_p:Float]⟶  ⊤+"1"  ――!"O1" []⟶  ⊥+"1"  ――!"confirm" [counter_p:Float]⟶  ⊥+"2"  ――?"register" [label_p:String]⟶  ⊤+"2"  ――?"update" [counter_p:Float]⟶  ⊤+"2"  ――!"O1" []⟶  (True, {},"0")+"2"  ――!"confirm" [counter_p:Float]⟶  ⊥+|]++----- Non-nominal cases -----++-- | Variable type "dummyType" is not recognised as a type.+testSTSJSONParserUnknownType :: Test+testSTSJSONParserUnknownType = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "unknown_type.json")+    assertErrorContains "unknown type" "unknown variable type: dummyType" result++-- | Variable "label" has type String but the assignment expression is an integer literal.+testSTSJSONParserAssignmentTypeMismatch :: Test+testSTSJSONParserAssignmentTypeMismatch = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "assignment_type_mismatch.json")+    assertErrorContains "Test assignment type mismatch" "not a string expression" result++-- | Guard compares integer with string using ==+testSTSJSONParserGuardTypeMismatch :: Test+testSTSJSONParserGuardTypeMismatch = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "guard_type_mismatch.json")+    assertErrorContains "Test guard type mismatch" "not a string expression" result++-- | Switch refers to an undefined gate+testSTSJSONParserGateIdDup :: Test+testSTSJSONParserGateIdDup = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "gate_id_dup.json")+    assertErrorContains "Test gate id inconsistency" "unknown gate" result++-- | Guard expression uses operator "??" which is not handled by toBoolExpr.+testSTSJSONParserUnsupportedGuardOperand :: Test+testSTSJSONParserUnsupportedGuardOperand = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "unsupported_guard_operand.json")+    assertErrorContains "Test unsupported guard operand" "not a boolean expression" result++-- | Assignment expression uses an unsupported operator+testSTSJSONParserUnsupportedAssignmentOperand :: Test+testSTSJSONParserUnsupportedAssignmentOperand = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "unsupported_assignment_operand.json")+    assertErrorContains "Test unsupported assignment operand" "not an integer expression" result++-- | The mandatory "switches" field is absent from the JSON.+testSTSJSONParserMissingSwitches :: Test+testSTSJSONParserMissingSwitches = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "missing_switches.json")+    assertErrorContains "Test missing switches" "switches" result+    assertErrorContains "Test missing switches" "not found" result++-- | A used input gate is absent from the JSON.+testSTSJSONParserMissingGates :: Test+testSTSJSONParserMissingGates = TestCase $ do+    result <- stsFromJSONFile (testDir ++ "missing_gates.json")+    assertErrorContains "Test missing inputGates" "unknown gate 'I1' in switch" result++stsJSONParserTests :: [Test]+stsJSONParserTests =+    [ testSTSJSONParserNominal+    , testSTSJSONParserNominalFloat+    , testSTSJSONParserUnknownType+    , testSTSJSONParserAssignmentTypeMismatch+    , testSTSJSONParserGuardTypeMismatch+    , testSTSJSONParserGateIdDup+    , testSTSJSONParserUnsupportedGuardOperand+    , testSTSJSONParserUnsupportedAssignmentOperand+    , testSTSJSONParserMissingSwitches+    , testSTSJSONParserMissingGates+    ]
+ test/Test/System/IO/Streams/Synchronized.hs view
@@ -0,0 +1,176 @@+module Test.System.IO.Streams.Synchronized (+prop_consumeBufferedWith,+testConsumeBufferedWith_short,+testConsumeBufferedWith,+prop_jsonStream+)+where++import Control.Applicative((<|>))+import Control.Concurrent.STM.TQueue(TQueue, newTQueueIO, writeTQueue, readTQueue, isEmptyTQueue)+import Control.Concurrent(threadDelay)+import Control.Arrow(first)+import Data.Aeson(FromJSON,ToJSON,encode,fromJSON)+import qualified Data.Aeson as Aeson(Result(..))+import Data.Aeson.Parser(jsonNoDup)+import qualified Data.Attoparsec.ByteString.Char8 as Parse++import Data.Bits.Utils(c2w8)+import Data.ByteString(ByteString)+import Data.ByteString.Lazy(toStrict,snoc)+import qualified Data.ByteString as BS(splitAt,length)+import Data.Functor(void)+import qualified Data.List as List(splitAt)+import GHC.Conc(atomically, newTVar, readTVar, writeTVar)+import Lattest.Streams.Synchronized (tryReadIO, Streamed(Available), consumeBufferedWith, makeTInputStream)+import qualified Lattest.Streams.Synchronized as Streams (hasInput,read,map)+import Lattest.Streams.Synchronized.Attoparsec(parserToInputStream)+import Test.HUnit+import Test.QuickCheck+import Test.QuickCheck.Monadic (assertWith, monadicIO, run)++data WaitTime = NoWT | ShortWT | LongWT deriving (Eq, Show, Ord)++instance Arbitrary WaitTime where+   arbitrary = elements [NoWT, ShortWT, LongWT]+   shrink NoWT = []+   shrink ShortWT = [NoWT]+   shrink LongWT = [NoWT, ShortWT]++waitTimeToMillis :: Num a => WaitTime -> a+waitTimeToMillis NoWT = 0+waitTimeToMillis ShortWT = 2+waitTimeToMillis LongWT = 20++prop_consumeBufferedWith :: ([[(Int, WaitTime)]], WaitTime) -> Property+prop_consumeBufferedWith = prop_consumeBufferedWith'++prop_consumeBufferedWith' :: (Eq a, Show a) => ([[(a, WaitTime)]], WaitTime) -> Property+prop_consumeBufferedWith' (testInput', lastWaitTime) = withMaxSuccess 15 $ monadicIO $ do+    let lastTestInput = (Nothing, lastWaitTime)+    let testInput = mapToLast (fmap (fmap (first Just)) testInput') (\x -> x ++ [lastTestInput]) [lastTestInput]+    queue <- run $ do+        queue' <- newTQueueIO :: IO (TQueue [Maybe a])+        sequence_ $ (atomically . writeTQueue queue' . fmap fst) <$> testInput -- write all lists to the queue, without wait times+        return queue'+    -- test the input stream created with consumeBufferedWith: for random lists of inputs, the stream should produce those original inputs, regardless of random waiting times in between reading+    is <- run $ consumeBufferedWith (readTQueue queue) (not <$> isEmptyTQueue queue)+    let (expected, waitTimes) = unzip $ concat testInput+    assertBufferedIS is expected waitTimes+    hasLast <- run $ atomically $ Streams.hasInput is+    assertWith hasLast "mbt test expected input, received no input at end of test"+    lastInput <- run $ atomically $ Streams.read is+    assertWith (lastInput == Nothing) ("expected Nothing, received " ++ show lastInput ++ " at end of test")+    where+    assertBufferedIS is es wts = assertBufferedIS' is es wts es+    assertBufferedIS' _ [] [] _ = return ()+    assertBufferedIS' is (e:es) (wt:wts) oes = do+        run $ threadDelay $ waitTimeToMillis wt * 1000+        hasNext <- run $ atomically $ Streams.hasInput is+        assertWith hasNext $ "mbt test expected " ++ show e ++ ", received no input in " ++ show oes+        next <- run $ atomically $ Streams.read is+        assertWith (e == next) ("expected " ++ show e ++ ", received " ++ show next ++ " in " ++ show oes)+        assertBufferedIS' is es wts oes+    mapToLast [] _ a = [a]+    mapToLast [lastElem] f _ = [f lastElem]+    mapToLast (a:as) f _ = (a:mapToLast as f (error "unused"))++testConsumeBufferedWith_short :: Test+testConsumeBufferedWith_short = TestCase $ do+    queue <- newTQueueIO :: IO (TQueue [Maybe a])+    is <- consumeBufferedWith (readTQueue queue) (not <$> isEmptyTQueue queue)+    sequence_ $ (atomically . writeTQueue queue) <$> [[Just "a"],[Nothing]]+    shouldBeA <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking a") (Just "a") shouldBeA+    shouldBeNothing <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking Nothing") (Nothing) shouldBeNothing++testConsumeBufferedWith :: Test+testConsumeBufferedWith = TestCase $ do+    queue <- newTQueueIO :: IO (TQueue [Maybe a])+    is <- consumeBufferedWith (readTQueue queue) (not <$> isEmptyTQueue queue)+    sequence_ $ (atomically . writeTQueue queue) <$> [[Just "a", Just "b"], [Just "c", Just "d"],[Just "e", Nothing]]+    shouldBeA <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking a") (Just "a") shouldBeA+    shouldBeB <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking b") (Just "b") shouldBeB+    shouldBeC <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking c") (Just "c") shouldBeC+    shouldBeD <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking d") (Just "d") shouldBeD+    shouldBeE <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking e") (Just "e") shouldBeE+    shouldBeNothing <- atomically $ Streams.read is+    assertEqual ("testConsumeBufferedWith checking Nothing") (Nothing) shouldBeNothing++prop_jsonStream :: (FromJSON a, ToJSON a, Show a, Eq a) => [(a,Bool,Bool)] -> Property+prop_jsonStream testInput = monadicIO $ do+    -- first bool in list states that the bytes of the next elements should be appended to the bytes of this elements. If the element is the last one, then this boolean states that the second half is included, as opposed to being omitted entirely (if the element is streamed as half bytestring), or is ignored (if the element is streamed as single bytestring).+    -- second bool in the list state that the bytes of the element should be streamed as two half bytestrings, as opposed to a single bytestring+    -- final bool states whether the bytes of the last bool are incomplete+    -- FIXME this does not test whether checkReadyness which results in False can later be succeeded by True, and by a succesfull read+    (typedData, byteData) <- run $ createTestData testInput -- make an input stream from someData by serializing them as bytestrings reporesenting JSON, and potentially cutting off the bytestring half way+    is <- run $ makeReader byteData+    actionStream <- run $ parserToInputStream ((Parse.endOfInput >> pure Nothing) <|> (Just <$> (Parse.skipSpace *> jsonNoDup))) is+    actionStream' <- run $ Streams.map (fromResult . fromJSON) actionStream+    +    -- assert that the parsed objects are equal to the original objects, minus the cut-off+    --return Discard+    void $ checkObjs actionStream' typedData+    where+    checkObjs _ [] = return []+    checkObjs actionStream [x] = checkObj actionStream x >>= \y -> return [y]+    checkObjs actionStream (x:xs) = do+        y <- checkObj actionStream x+        ys <- checkObjs actionStream xs+        return (y:ys)+    checkObj actionStream obj = do+        received <- run $ tryReadIO actionStream+        --assert (isJust maybeReceived)+        assertWith (Available obj == received) ("checkObjs expected " ++ show obj ++ ", received " ++ show received)+        return $ fromAvailable received+    fromAvailable (Available o) = o+    createTestData [] = return ([], [])+    createTestData [(a,app,True)] = do+        let b = encode' a+        (h1, h2) <- splitAtRandom b+        return (if app then [a] else [], h1 : if app then [h2] else [])+    createTestData [(a,_,False)] = return ([a],[encode' a])+    createTestData ((a,app,half):rest) = do+        (as,bytes) <- createTestData rest+        let b = encode' a+        bytes'' <- if half+            then do+                (h1, h2) <- splitAtRandom b+                return $ if app+                    then let ([h2'],bytes') = List.splitAt 1 bytes+                        in h1:(h2 `mappend` h2'):bytes'+                    else h1:h2:bytes+            else return $ if app+                then let ([b'],bytes') = List.splitAt 1 bytes+                    in (b `mappend` b'):bytes'+                else b:bytes+        return (a:as,bytes'')+    splitAtRandom :: ByteString -> IO (ByteString,ByteString)+    splitAtRandom b = +        if BS.length b > 1+            then do+                i <- generate $ chooseInt (1, BS.length b - 1)+                return $ BS.splitAt i b+            else discard+    encode' = toStrict . (flip snoc $ c2w8 '\n') . encode+    makeReader someData = do+        tSomeData <- atomically $ newTVar someData+        makeTInputStream (consume tSomeData) (return True)+        where+        consume tSomeData = do+            someData' <- readTVar tSomeData+            case someData' of+                [] -> return Nothing+                (x:xs) -> do+                    writeTVar tSomeData xs+                    return $ Just x+    fromResult (Aeson.Success s) = s+    fromResult (Aeson.Error e) = undefined e -- TODO handle error case++