diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ ## Unreleased +## 0.4.0.0 - 2026-03-16 + +### Changed +- Changed the types of oracles' constructors from `` to `Either String ` + where `String` is an error message indicating invalid values to ``. + Now, for example, instead of `oracle = mkWMethod (WMethodConfig 2)`, one should either + pattern match with `case` or do `oracle = either error id (mkWMethod (WMethodConfig 2))`. + ## 0.3.0.0 - 2026-03-11 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -105,8 +105,11 @@ ghci| sulTransitions S2 A = (S0, X) ghci| sulTransitions S2 B = (S0, Y) +ghci> learner = mkLMstar Star +ghci> teacher = either error id (mkWMethod (WMethodConfig 2)) + -- Set up the experiment. -ghci> myexperiment = experiment (mkLMstar Star) (mkWMethod 2) +ghci> myexperiment = experiment learner teacher -- Define the Mealy system under learning. Remember that automata can act as suls. ghci> mysul = mkMealyAutomaton2 sulTransitions (Set.fromList [S0, S1, S2]) S0 diff --git a/examples/demo.hs b/examples/demo.hs --- a/examples/demo.hs +++ b/examples/demo.hs @@ -17,8 +17,13 @@ sulTransitions S2 A = (S0, X) sulTransitions S2 B = (S0, Y) +learner = mkLMstar Star +oracle = case mkWMethod (WMethodConfig 2) of + Left msg -> error msg + Right oracle' -> oracle' + -- Set up the experiment. -myexperiment = experiment (mkLMstar Star) (mkWMethod (WMethodConfig 2)) +myexperiment = experiment learner oracle -- Define the Mealy system under learning. Remember that automata can act as suls. mysul = mkMealyAutomaton2 sulTransitions (Set.fromList [S0, S1, S2]) S0 diff --git a/examples/div.hs b/examples/div.hs --- a/examples/div.hs +++ b/examples/div.hs @@ -83,7 +83,9 @@ learner = mkLMstar Star oracle :: WpMethod -oracle = mkWpMethod (WpMethodConfig 3) +oracle = case mkWpMethod (WpMethodConfig 3) of + Left msg -> error msg + Right oracle' -> oracle' exper :: Experiment (Program Binary Bool) (MealyAutomaton StateID Binary Bool, Statistics MealyAutomaton StateID Binary Bool) exper = experiment learner oracle diff --git a/examples/io.hs b/examples/io.hs --- a/examples/io.hs +++ b/examples/io.hs @@ -77,7 +77,9 @@ learner = mkLMstar Star oracle :: WpMethod -oracle = mkWpMethod (WpMethodConfig 3) +oracle = case mkWpMethod (WpMethodConfig 3) of + Left msg -> error msg + Right oracle' -> oracle' exper :: ExperimentT diff --git a/examples/website.hs b/examples/website.hs --- a/examples/website.hs +++ b/examples/website.hs @@ -85,7 +85,9 @@ -------------------------------------------------------------------------------- learner = mkLMstar Star -teacher = mkWMethod (WMethodConfig 2) +teacher = case mkWMethod (WMethodConfig 2) of + Left msg -> error msg + Right oracle -> oracle exper = experiment learner teacher -------------------------------------------------------------------------------- diff --git a/haal.cabal b/haal.cabal --- a/haal.cabal +++ b/haal.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haal -version: 0.3.0.0 +version: 0.4.0.0 synopsis: A Haskell library for Active Automata Learning. description: Please see the README on GitHub at category: Model Learning diff --git a/src/Haal/EquivalenceOracle/RandomWalk.hs b/src/Haal/EquivalenceOracle/RandomWalk.hs --- a/src/Haal/EquivalenceOracle/RandomWalk.hs +++ b/src/Haal/EquivalenceOracle/RandomWalk.hs @@ -28,8 +28,10 @@ newtype RandomWalk = RandomWalk RandomWalkConfig deriving (Show, Eq) -- | Constructor for a 'RandomWalk' value. -mkRandomWalk :: RandomWalkConfig -> RandomWalk -mkRandomWalk = RandomWalk +mkRandomWalk :: RandomWalkConfig -> Either String RandomWalk +mkRandomWalk cfg + | 0 <= rwlMaxSteps cfg && 0 <= rwlRestart cfg && rwlRestart cfg <= 1 = Right (RandomWalk cfg) + | otherwise = Left ("Must be 0 <= rwlMaxSteps and 0 <= rwlRestart <= 1 but got " ++ show cfg) -- | Generates a random walk for the automaton. randomWalkSuite :: (FiniteOrd a) => RandomWalk -> sul a o -> (RandomWalk, [[a]]) @@ -39,7 +41,7 @@ randomInputs = take maxS $ randomRs (0, V.length alphabet - 1) g1 inputSequence = map (alphabet V.!) randomInputs (inputSequence', g3) = splitWithProbability g2 restartP inputSequence - oracle' = mkRandomWalk (RandomWalkConfig g3 maxS restartP) + oracle' = RandomWalk (RandomWalkConfig g3 maxS restartP) in (oracle', inputSequence') splitWithProbability :: StdGen -> Double -> [a] -> ([[a]], StdGen) diff --git a/src/Haal/EquivalenceOracle/RandomWords.hs b/src/Haal/EquivalenceOracle/RandomWords.hs --- a/src/Haal/EquivalenceOracle/RandomWords.hs +++ b/src/Haal/EquivalenceOracle/RandomWords.hs @@ -28,8 +28,14 @@ newtype RandomWords = RandomWords RandomWordsConfig deriving (Show, Eq) -- | Constructor for a 'RandomWords' data type. -mkRandomWords :: RandomWordsConfig -> RandomWords -mkRandomWords = RandomWords +mkRandomWords :: RandomWordsConfig -> Either String RandomWords +mkRandomWords cfg + | 0 <= rwLimit cfg && 0 <= rwMinLength cfg && rwMinLength cfg <= rwMaxLength cfg = Right (RandomWords cfg) + | otherwise = + Left + ( "Must be 0 <= rwLimit, and 0 <= rwMinLength <= rwMaxLength but got" + ++ show cfg + ) -- | Accessor for the 'RandomWordsConfig' of a 'RandomWords' value. randomWordsConfig :: RandomWords -> RandomWordsConfig @@ -48,7 +54,7 @@ ) aut = let (ranWords, finalGen) = runState (replicateM count genWord) generator - oracle = mkRandomWords (RandomWordsConfig finalGen count minL maxL) + oracle = RandomWords (RandomWordsConfig finalGen count minL maxL) in (oracle, ranWords) where alphaVec = V.fromList . Set.toList $ inputs aut diff --git a/src/Haal/EquivalenceOracle/WMethod.hs b/src/Haal/EquivalenceOracle/WMethod.hs --- a/src/Haal/EquivalenceOracle/WMethod.hs +++ b/src/Haal/EquivalenceOracle/WMethod.hs @@ -12,30 +12,29 @@ ) where import Control.Monad (replicateM) -import qualified Data.List as List +import Control.Monad.State (runState, state) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Vector as Vec import Haal.BlackBox -import Haal.EquivalenceOracle.RandomWords (RandomWordsConfig (..), mkRandomWords, randomWordsConfig) import Haal.Experiment -import System.Random (Random (randomRs), RandomGen (split), StdGen) +import System.Random (Random (randomR), StdGen) -{- | The 'WMethodConfig' type is used to configure the W-method equivalence oracle. --} +-- | The 'WMethodConfig' type is used to configure the W-method equivalence oracle. data WMethodConfig = WMethodConfig { wmDepth :: Int -- ^ The number of extra states beyond the hypothesis to account for. } deriving (Show, Eq) -{- | The 'WMethod' type represents the W-method equivalence oracle. --} +-- | The 'WMethod' type represents the W-method equivalence oracle. newtype WMethod = WMethod WMethodConfig deriving (Show, Eq) -- | Constructor for a 'WMethod' value. -mkWMethod :: WMethodConfig -> WMethod -mkWMethod = WMethod +mkWMethod :: WMethodConfig -> Either String WMethod +mkWMethod cfg + | 0 <= wmDepth cfg = Right (WMethod cfg) + | otherwise = Left ("Must be 0 <= wmDepth but got " ++ show cfg) -- | The 'wmethodSuiteSize' function computes the size of the test suite for the W-method. wmethodSuiteSize :: @@ -97,8 +96,10 @@ newtype RandomWMethod = RandomWMethod RandomWMethodConfig deriving (Show, Eq) -- | Constructor for a 'RandomWMethod' value. -mkRandomWMethod :: RandomWMethodConfig -> RandomWMethod -mkRandomWMethod = RandomWMethod +mkRandomWMethod :: RandomWMethodConfig -> Either String RandomWMethod +mkRandomWMethod cfg + | 0 <= rwmLimit cfg && 0 <= rwmLength cfg = Right (RandomWMethod cfg) + | otherwise = Left ("Must be 0 <= rwmLimit and 0 <= rwmLength but got " ++ show cfg) -- | The 'randomWMethodSuite' function generates the test suite for the random W-method and a new oracle. randomWMethodSuite :: @@ -112,20 +113,24 @@ aut s i o -> (RandomWMethod, [[i]]) randomWMethodSuite (RandomWMethod (RandomWMethodConfig g wpr wl)) aut = - let rorc = mkRandomWords (RandomWordsConfig{rwMaxLength = wl, rwMinLength = 1, rwLimit = wpr, rwGen = g}) - prefixes = Map.elems $ accessSequences aut - vecSuffixes = Vec.fromList $ Set.toList $ globalCharacterizingSet aut - - (rorc', wordBatches) = List.mapAccumL testSuite rorc (replicate (length prefixes) (undefined :: aut s i o)) - flatWords = concat wordBatches - - (gen'', gen''') = split (rwGen (randomWordsConfig rorc')) - samples = length prefixes * wpr - randomSuffixes = take samples $ randomRs (0, Vec.length vecSuffixes - 1) gen'' - suffixes = map (vecSuffixes Vec.!) randomSuffixes - - suite = [prefix ++ rand ++ suffix | prefix <- prefixes, rand <- flatWords, suffix <- suffixes] - in (mkRandomWMethod (RandomWMethodConfig gen''' wpr wl), suite) + let prefixes = Map.elems $ accessSequences aut + suffixes = Set.toList $ globalCharacterizingSet aut + alphaVec = Vec.fromList . Set.toList $ inputs aut + genWord = + if wl == 0 + then return [] + else do + len <- state $ randomR (1, wl) + replicateM + len + ( state $ + \gen -> + let (ix, gen') = randomR (0, Vec.length alphaVec - 1) gen + in (alphaVec Vec.! ix, gen') + ) + (ranWords, g') = runState (replicateM wpr genWord) g + suite = [prefix ++ rand ++ suffix | prefix <- prefixes, rand <- ranWords, suffix <- suffixes] + in (RandomWMethod (RandomWMethodConfig g' wpr wl), suite) instance EquivalenceOracle RandomWMethod where testSuite = randomWMethodSuite diff --git a/src/Haal/EquivalenceOracle/WpMethod.hs b/src/Haal/EquivalenceOracle/WpMethod.hs --- a/src/Haal/EquivalenceOracle/WpMethod.hs +++ b/src/Haal/EquivalenceOracle/WpMethod.hs @@ -31,8 +31,10 @@ newtype WpMethod = WpMethod WpMethodConfig deriving (Eq, Show) -- | Constructor for a 'WpMethod' value. -mkWpMethod :: WpMethodConfig -> WpMethod -mkWpMethod = WpMethod +mkWpMethod :: WpMethodConfig -> Either String WpMethod +mkWpMethod cfg + | 0 <= wpmDepth cfg = Right (WpMethod cfg) + | otherwise = Left ("Must be 0 <= wpmDepth but got " ++ show cfg) -- | The 'wpmethodSuiteSize' returns the number of test cases in the test suite of WpMethod. wpmethodSuiteSize :: @@ -150,8 +152,14 @@ newtype RandomWpMethod = RandomWpMethod RandomWpMethodConfig deriving (Show, Eq) -- | Constructor for a 'RandomWpMethod' value. -mkRandomWpMethod :: RandomWpMethodConfig -> RandomWpMethod -mkRandomWpMethod = RandomWpMethod +mkRandomWpMethod :: RandomWpMethodConfig -> Either String RandomWpMethod +mkRandomWpMethod cfg + | 0 <= rwpMin cfg && rwpMin cfg <= rwpExpected cfg && 0 <= rwpLimit cfg = Right (RandomWpMethod cfg) + | otherwise = + Left + ( "Must be 0 <= rwpMin <= rwpExpected and 0 <= rwpLimit but got " + ++ show cfg + ) -- | Return the 'RandomWpMethod' test suite. randomWpMethodSuite :: diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} +{- HLINT ignore "Use <$>" -} module Utils ( statesAreEquivalent, @@ -84,7 +85,7 @@ instance Arbitrary ArbWMethod where arbitrary = do (ArbWMethodConfig config) <- arbitrary :: Gen ArbWMethodConfig - return (ArbWMethod (mkWMethod config)) + return (ArbWMethod (either error id (mkWMethod config))) instance Arbitrary ArbWpMethodConfig where arbitrary = do @@ -93,7 +94,7 @@ instance Arbitrary ArbWpMethod where arbitrary = do (ArbWpMethodConfig config) <- arbitrary :: Gen ArbWpMethodConfig - return (ArbWpMethod (mkWpMethod config)) + return (ArbWpMethod (either error id (mkWpMethod config))) instance Arbitrary ArbRandomWordsConfig where arbitrary = do @@ -106,7 +107,7 @@ instance Arbitrary ArbRandomWords where arbitrary = do (ArbRandomWordsConfig config) <- arbitrary :: Gen ArbRandomWordsConfig - return (ArbRandomWords (mkRandomWords config)) + return (ArbRandomWords (either error id (mkRandomWords config))) instance Arbitrary ArbRandomWalkConfig where arbitrary = do @@ -118,7 +119,7 @@ instance Arbitrary ArbRandomWalk where arbitrary = do (ArbRandomWalkConfig config) <- arbitrary :: Gen ArbRandomWalkConfig - return (ArbRandomWalk (mkRandomWalk config)) + return (ArbRandomWalk (either error id (mkRandomWalk config))) instance Arbitrary ArbRandomWMethodConfig where arbitrary = do @@ -130,7 +131,7 @@ instance Arbitrary ArbRandomWMethod where arbitrary = do (ArbRandomWMethodConfig config) <- arbitrary :: Gen ArbRandomWMethodConfig - return (ArbRandomWMethod (mkRandomWMethod config)) + return (ArbRandomWMethod (either error id (mkRandomWMethod config))) instance Arbitrary ArbRandomWpMethodConfig where arbitrary = do @@ -144,7 +145,7 @@ instance Arbitrary ArbRandomWpMethod where arbitrary = do (ArbRandomWpMethodConfig config) <- arbitrary :: Gen ArbRandomWpMethodConfig - return (ArbRandomWpMethod (mkRandomWpMethod config)) + return (ArbRandomWpMethod (either error id (mkRandomWpMethod config))) class (EquivalenceOracle oracle) => OracleWrapper w oracle | w -> oracle where unwrap :: w -> oracle