script-monad 0.0.1 → 0.0.2
raw patch · 8 files changed
+479/−972 lines, 8 filesdep +tasty-quickcheck-lawsdep ~QuickCheckdep ~aesondep ~aeson-pretty
Dependencies added: tasty-quickcheck-laws
Dependency ranges changed: QuickCheck, aeson, aeson-pretty, bytestring, http-client, http-types, lens, lens-aeson, tasty, tasty-hunit, tasty-quickcheck, text, time, unordered-containers, vector, wreq
Files
- ChangeLog.md +22/−5
- script-monad.cabal +20/−18
- src/Control/Monad/Script.hs +29/−10
- src/Control/Monad/Script/Http.hs +203/−96
- src/Data/LogSeverity.hs +44/−0
- test/Control/Monad/Script/Http/Test.hs +8/−8
- test/Control/Monad/Script/Test.hs +107/−513
- test/Data/MockIO/Test.hs +46/−322
ChangeLog.md view
@@ -1,12 +1,29 @@-# Changelog for script-monad+Changelog for script-monad+========================== -## Unreleased changes+0.0.2+----- -(none)+* Added+ * ScriptT: `draft` function+ * HttpT: `catchAnyError` function+ * HttpT: `logDebug`, `logInfo`, `logNotice`, `logWarning`, `logError`, `logCritical`,+ `logAlert`, `logEmergency`, and `setLogSeverity` functions+ * HttpT: `printHttpLogs`+ * HttpT: `_logMinSeverity` option+* Changed+ * HttpT: refactored logging to use syslog conventions+* Fixed+ * ScriptT: Bug in implementation of `catch` was cutting off the logs+* Removed+ * HttpT: `logEntry` function; deprecated in favor of syslog-flavored logger functions -## 0.0.1 -* New++0.0.1+-----++* Added * Script and ScriptT: Hand-rolled stack of error, reader, writer, state, and prompt * Http and HttpT: Monad transformer for HTTP sessions with batteries included * MockIO: Fake IO monad for testing
script-monad.cabal view
@@ -1,5 +1,5 @@ name: script-monad-version: 0.0.1+version: 0.0.2 description: Please see the README on GitHub at <https://github.com/nbloomf/script-monad#readme> homepage: https://github.com/nbloomf/script-monad#readme bug-reports: https://github.com/nbloomf/script-monad/issues@@ -28,19 +28,19 @@ build-depends: base >=4.7 && <5 - , aeson >=1.2.4.0 && <1.3- , aeson-pretty >=0.8.5 && <0.9- , bytestring >=0.10.8.2 && <0.11- , http-client >=0.5.10 && <0.6- , http-types >=0.12.1 && <0.13- , lens >=4.16 && <4.17- , lens-aeson >=1.0.2 && <1.1- , QuickCheck >=2.10.1 && <2.11- , text >=1.2.3.0 && <1.3- , time >=1.8.0.2 && <1.9- , unordered-containers >=0.2.9.0 && <0.3- , vector >=0.12.0.1 && <0.13- , wreq >=0.5.2 && <0.6+ , aeson >=1.2.4.0+ , aeson-pretty >=0.8.5+ , bytestring >=0.10.8.2+ , http-client >=0.5.10+ , http-types >=0.12.1+ , lens >=4.16+ , lens-aeson >=1.0.2+ , QuickCheck >=2.10.1+ , text >=1.2.3.0+ , time >=1.8.0.2+ , unordered-containers >=0.2.9.0+ , vector >=0.12.0.1+ , wreq >=0.5.2 exposed-modules: Control.Monad.Script@@ -50,6 +50,7 @@ other-modules: Data.Aeson.Extras+ , Data.LogSeverity , Network.HTTP.Client.Extras @@ -76,10 +77,11 @@ base >=4.7 && <5 , script-monad - , bytestring >=0.10.8.2 && <0.11- , tasty >=1.0.1.1 && <1.1- , tasty-hunit >=0.10.0.1 && <0.11- , tasty-quickcheck >=0.9.2 && <1.0+ , bytestring >=0.10.8.2+ , tasty >=1.0.1.1+ , tasty-hunit >=0.10.0.1+ , tasty-quickcheck >=0.9.2+ , tasty-quickcheck-laws >= 0.0.1 other-modules: Control.Monad.Script.Test
src/Control/Monad/Script.hs view
@@ -41,6 +41,7 @@ -- * Writer , tell+ , draft , listen , pass , censor@@ -102,7 +103,10 @@ Right y -> do let h (z2,s2,w2) = end (z2, s2, mappend w1 w2) runScriptT (f y) (s1,r) h cont- Left e -> end (Left e, s1, w1)+ Left e -> do+ let h (_,s2,w2) = end (Left e, s2, mappend w1 w2)+ runScriptT (return ()) (s1,r) h cont+ runScriptT x (s0,r) g cont instance (Monoid w) => Applicative (ScriptT e r w s p m) where@@ -162,13 +166,13 @@ -- | Execute a 'ScriptT' with a specified inital state and environment, and with a monadic evaluator. In this case the inner monad @m@ will typically be a monad transformer over the effect monad @n@. execScriptTM- :: (Monad (m n), Monad n)+ :: (Monad (m eff), Monad eff) => s -- ^ Initial state -> r -- ^ Environment- -> (forall u. p u -> n u) -- ^ Monadic effect evaluator- -> (forall u. n u -> m n u) -- ^ Lift effects to the inner monad- -> ScriptT e r w s p (m n) t- -> m n (Either e t, s, w)+ -> (forall u. p u -> eff u) -- ^ Monadic effect evaluator+ -> (forall u. eff u -> m eff u) -- ^ Lift effects to the inner monad+ -> ScriptT e r w s p (m eff) t+ -> m eff (Either e t, s, w) execScriptTM s r eval lift = execScriptTC s r return (\p c -> (lift $ eval p) >>= c)@@ -349,6 +353,17 @@ +-- | Run an action and attach the log to the result, setting the log to `mempty`.+draft+ :: (Monoid w)+ => ScriptT e r w s p m a+ -> ScriptT e r w s p m (a,w)+draft x = ScriptT $ \(r,s) -> \end cont ->+ runScriptT x (r,s)+ (\(y,s,w) -> end (fmap (,w) y, s, mempty)) cont+++ -- | Run an action and attach the log to the result. listen :: ScriptT e r w s p m a@@ -419,21 +434,25 @@ :: (Monoid w) => e -> ScriptT e r w s p m a-throw e = ScriptT $ \(s,_) -> \end _ ->- end (Left e, s, mempty)+throw e = ScriptT $ \(s,r) -> \end cont ->+ let end' (_,s1,w1) = end (Left e, s1, w1)+ in runScriptT (return ()) (s,r) end' cont -- | Run an action, applying a handler in case of an error result. catch- :: ScriptT e r w s p m a+ :: (Monoid w)+ => ScriptT e r w s p m a -> (e -> ScriptT e r w s p m a) -> ScriptT e r w s p m a catch x h = ScriptT $ \(s,r) -> \end cont -> let end' (z,s1,w) = case z of Right y -> end (Right y, s1, w)- Left e -> runScriptT (h e) (s1,r) end cont+ Left e -> do+ let end'' (z2,s2,w2) = end (z2, s2, mappend w w2)+ runScriptT (h e) (s1,r) end'' cont in runScriptT x (s,r) end' cont
src/Control/Monad/Script/Http.hs view
@@ -30,6 +30,7 @@ , catchJsonError , catchHttpException , catchIOException+ , catchAnyError , printError , E() @@ -46,7 +47,11 @@ -- * Writer , logEntries+ , LogSeverity(..)+ , setLogSeverity , W()+ , printHttpLogs+ , basicLogEntryPrinter -- * State , gets@@ -63,7 +68,14 @@ -- * API , comment , wait- , logEntry+ , logDebug+ , logInfo+ , logNotice+ , logWarning+ , logError+ , logCritical+ , logAlert+ , logEmergency -- ** IO , Control.Monad.Script.Http.hPutStrLn@@ -122,6 +134,8 @@ ( lookup ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef )+import Data.List+ ( intercalate ) import Data.String ( fromString ) import Data.Text@@ -155,6 +169,7 @@ import qualified Control.Monad.Script as S import Network.HTTP.Client.Extras import Data.Aeson.Extras+import Data.LogSeverity import Data.MockIO import Data.MockIO.FileSystem @@ -352,7 +367,7 @@ :: HttpException -> HttpT e r w s p m a throwHttpException e = do- logNow $ errorMessage $ E_Http e+ logNow LogError $ errorMessage $ E_Http e throw $ E_Http e -- | Re-throws other error types.@@ -370,7 +385,7 @@ :: IOException -> HttpT e r w s p m a throwIOException e = do- logNow $ errorMessage $ E_IO e+ logNow LogError $ errorMessage $ E_IO e throw $ E_IO e -- | Re-throws other error types.@@ -388,7 +403,7 @@ :: JsonError -> HttpT e r w s p m a throwJsonError e = do- logNow $ errorMessage $ E_Json e+ logNow LogError $ errorMessage $ E_Json e throw $ E_Json e -- | Re-throws other error types.@@ -406,7 +421,7 @@ :: e -> HttpT e r w s p m a throwError e = do- logNow $ errorMessage $ E e+ logNow LogError $ errorMessage $ E e throw $ E e -- | Re-throws other error types.@@ -419,12 +434,30 @@ E e -> handler e _ -> throw err +-- | Handle any thrown error. To handle only errors of a specific type, see @catchError@, @catchJsonError@, @catchIOException@, or @catchHttpException@.+catchAnyError+ :: HttpT e r w s p m a+ -> (e -> HttpT e r w s p m a)+ -> (HttpException -> HttpT e r w s p m a)+ -> (IOException -> HttpT e r w s p m a)+ -> (JsonError -> HttpT e r w s p m a)+ -> HttpT e r w s p m a+catchAnyError x hE hHttp hIO hJson =+ catch x $ \err -> case err of+ E e -> hE e+ E_Http e -> hHttp e+ E_IO e -> hIO e+ E_Json e -> hJson e + -- | Generic session environment. data R e w r = R { _logOptions :: LogOptions e w + -- | Printer for log entries.+ , _logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe String+ -- | Handle for printing logs , _logHandle :: Handle @@ -449,6 +482,7 @@ basicEnv r = R { _httpErrorInject = const Nothing , _logOptions = basicLogOptions+ , _logEntryPrinter = basicLogEntryPrinter , _logHandle = stdout , _logLock = Nothing , _uid = ""@@ -462,6 +496,7 @@ trivialEnv r = R { _httpErrorInject = const Nothing , _logOptions = trivialLogOptions+ , _logEntryPrinter = basicLogEntryPrinter , _logHandle = stdout , _logLock = Nothing , _uid = ""@@ -479,12 +514,12 @@ -- | Toggle to silence the logs , _logSilent :: Bool + -- | Suppress log output below this severity+ , _logMinSeverity :: LogSeverity+ -- | Toggle for printing HTTP headers , _logHeaders :: Bool - -- | Printer for log entries; first argument colorizes a string, and the tuple argument is (timestamp, uid, message).- , _logEntryPrinter :: (String -> String) -> (String, String, String) -> String- -- | Printer for client-supplied error type. The boolean toggles JSON pretty printing. , _printUserError :: Bool -> e -> String @@ -498,8 +533,8 @@ { _logColor = True , _logJson = False , _logSilent = False+ , _logMinSeverity = LogDebug , _logHeaders = True- , _logEntryPrinter = basicLogEntryPrinter , _printUserError = \_ e -> show e , _printUserLog = \_ w -> show w }@@ -510,29 +545,54 @@ { _logColor = True , _logJson = False , _logSilent = False+ , _logMinSeverity = LogDebug , _logHeaders = True- , _logEntryPrinter = basicLogEntryPrinter , _printUserError = \_ _ -> "ERROR" , _printUserLog = \_ _ -> "LOG" } +-- | Simple default pretty printer for @LogEntry@s. basicLogEntryPrinter- :: (String -> String)- -> (String, String, String)- -> String-basicLogEntryPrinter colorize (timestamp, uid, msg) =- unwords $ filter (/= "")- [ colorize timestamp, uid, msg ]+ :: LogOptions e w+ -> LogEntry e w+ -> Maybe String+basicLogEntryPrinter opt@LogOptions{..} LogEntry{..} =+ if _logSilent || (_logEntrySeverity < _logMinSeverity)+ then Nothing+ else+ let+ colorize msg = if _logColor+ then colorBySeverity _logEntrySeverity msg+ else msg + timestamp :: String+ timestamp = take 19 $ show _logEntryTimestamp+ in+ Just $ unwords $ filter (/= "")+ [ colorize timestamp+ , _logEntryUID+ , logEntryTitle _logEntry+ , logEntryBody opt _logEntry+ ] + -- | Log type-data W e w = W [(UTCTime, Log e w)]+newtype W e w = W+ { unW :: [LogEntry e w]+ } deriving Show instance Monoid (W e w) where mempty = W [] mappend (W a1) (W a2) = W (a1 ++ a2) +data LogEntry e w = LogEntry+ { _logEntryTimestamp :: UTCTime+ , _logEntryUID :: String+ , _logEntrySeverity :: LogSeverity+ , _logEntry :: Log e w+ } deriving Show+ -- | Log entry type data Log e w = L_Comment String@@ -552,13 +612,50 @@ | L_Log w deriving Show +logEntryTitle :: Log e w -> LogEntryTitle+logEntryTitle e = case e of+ L_Comment _ -> "Comment"+ L_Request _ _ _ _ -> "Request"+ L_SilentRequest -> "Silent Request"+ L_Response _ -> "Response"+ L_SilentResponse -> "Silent Response"+ L_Pause _ -> "Pause"+ L_HttpError _ -> "HTTP Exception"+ L_IOError _ -> "IO Exception"+ L_JsonError _ -> "JSON Error"+ L_Error _ -> "Error"+ L_Log _ -> "Log"+ -- | Used in the logs. data HttpVerb = DELETE | GET | POST deriving (Eq, Show) +-- | All log statements should go through @logNow@.+printHttpLogs+ :: Handle+ -> Maybe (MVar ())+ -> LogOptions e w+ -> (LogOptions e w -> LogEntry e w -> Maybe String)+ -> W e w+ -> IO ()+printHttpLogs handle lock opts printer (W ws) = do+ let+ printEntry w = + case printer opts w of+ Nothing -> return ()+ Just str -> do+ case lock of+ Just lock -> withMVar lock (\() -> System.IO.hPutStrLn handle str)+ Nothing -> System.IO.hPutStrLn handle str+ hFlush handle + if _logSilent opts+ then return ()+ else mapM_ printEntry ws ++ -- | Convert errors to log entries errorMessage :: E e -> Log e w errorMessage e = case e of@@ -567,36 +664,24 @@ E_Json err -> L_JsonError err E e -> L_Error e --- | Used to specify colors for user-supplied log entries.-data Color- = Red | Blue | Green | Yellow | Magenta--inColor :: Color -> String -> String-inColor c msg = case c of- Red -> "\x1b[1;31m" ++ msg ++ "\x1b[0;39;49m"- Blue -> "\x1b[1;34m" ++ msg ++ "\x1b[0;39;49m"- Green -> "\x1b[1;32m" ++ msg ++ "\x1b[0;39;49m"- Yellow -> "\x1b[1;33m" ++ msg ++ "\x1b[0;39;49m"- Magenta -> "\x1b[1;35m" ++ msg ++ "\x1b[0;39;49m"+type LogEntryTitle = String+type LogEntryBody = String -printEntryWith- :: Bool -- ^ Json- -> Bool -- ^ Headers- -> (Bool -> e -> String)- -> (Bool -> w -> String)+logEntryBody+ :: LogOptions e w -> Log e w- -> (Color, String)-printEntryWith asJson showHeaders printError printLog entry = case entry of- L_Comment msg -> (Green, msg)+ -> LogEntryBody+logEntryBody LogOptions{..} entry = case entry of+ L_Comment msg -> msg L_Request verb url opt payload -> let- head = case (asJson, showHeaders) of+ head = case (_logJson, _logHeaders) of (True, True) -> unpack $ encodePretty $ jsonResponseHeaders $ opt ^. Wreq.headers (False, True) -> show $ opt ^. Wreq.headers (_, False) -> "" - body = case (asJson, payload) of+ body = case (_logJson, payload) of (True, Just p) -> case decode p of Nothing -> "JSON parse error:\n" ++ unpack p Just v -> unpack $ encodePretty (v :: Value)@@ -604,29 +689,29 @@ (_, Nothing) -> "" in- (Blue, unlines $ filter (/= "") [unwords ["Request", show verb, url], head, body])+ intercalate "\n" $ filter (/= "") [unwords ["Request", show verb, url], head, body] - L_SilentRequest -> (Blue, "Silent Request")+ L_SilentRequest -> "" L_Response response -> let- head = case (asJson, showHeaders) of+ head = case (_logJson, _logHeaders) of (True, True) -> unpack $ encodePretty $ jsonResponseHeaders $ _responseHeaders response (False, True) -> show $ _responseHeaders response (_, False) -> "" - body = case asJson of+ body = case _logJson of True -> unpack $ encodePretty $ preview _Value $ _responseBody response False -> show response in- (Blue, unlines $ filter (/= "") ["Response", head, body])+ intercalate "\n" $ filter (/= "") ["Response", head, body] - L_SilentResponse -> (Blue, "Silent Response")+ L_SilentResponse -> "" - L_Pause k -> (Magenta, "Wait for " ++ show k ++ "μs")+ L_Pause k -> "Wait for " ++ show k ++ "μs" - L_HttpError e -> if asJson+ L_HttpError e -> if _logJson then let unpackHttpError :: HttpException -> Maybe (String, String)@@ -638,46 +723,27 @@ _ -> Nothing in case unpackHttpError e of- Nothing -> (Red, show e)- Just (code, json) -> (Red, unlines [ unwords [ "HTTP Error Response", code], json ])+ Nothing -> show e+ Just (code, json) -> intercalate "\n" [ unwords [ "HTTP Error Response", code], json ] - else (Red, show e)+ else show e - L_IOError e -> (Red, unwords [ show $ ioeGetFileName e, ioeGetLocation e, ioeGetErrorString e ])+ L_IOError e -> unwords [ show $ ioeGetFileName e, ioeGetLocation e, ioeGetErrorString e ] - L_JsonError e -> (Red, "JSON Error: " ++ show e)+ L_JsonError e -> show e - L_Error e -> (Red, unwords [ "ERROR", printError asJson e ])+ L_Error e -> unwords [ _printUserError _logJson e ] - L_Log w -> (Yellow, unwords [ "INFO", printLog asJson w ])+ L_Log w -> unwords [ _printUserLog _logJson w ] --- | Render a log entry-printLogWith- :: LogOptions e w- -> ((String -> String) -> (String, String, String) -> String)- -> (UTCTime, String, Log e w)- -> Maybe String-printLogWith opt@LogOptions{..} printer (timestamp, uid, entry) =- if _logSilent- then Nothing- else do- let- time :: String- time = take 19 $ show timestamp - color :: Color -> String -> String- color c = if _logColor then inColor c else id - (c,msg) = printEntryWith _logJson _logHeaders _printUserError _printUserLog entry-- Just $ printer (color c) (time, uid, msg)- -- | Extract the user-defined log entries. logEntries :: W e w -> [w] logEntries (W xs) = entries xs where entries [] = []- entries ((_,w):ws) = case w of+ entries (w:ws) = case _logEntry w of L_Log u -> u : entries ws _ -> entries ws @@ -808,41 +874,82 @@ -- | All log statements should go through @logNow@. logNow- :: Log e w+ :: LogSeverity+ -> Log e w -> HttpT e r w s p m ()-logNow msg = do+logNow severity msg = do time <- prompt GetSystemTime- printer <- reader (_logEntryPrinter . _logOptions)+ printer <- reader _logEntryPrinter R{..} <- ask- case printLogWith _logOptions printer (time,_uid,msg) of+ case printer _logOptions (LogEntry time _uid severity msg) of Nothing -> return () Just str -> case _logLock of Just lock -> hPutStrLnBlocking lock _logHandle str Nothing -> Control.Monad.Script.Http.hPutStrLn _logHandle str- tell $ W [(time, msg)]+ tell $ W [LogEntry time _uid severity msg] -- | Write a comment to the log comment :: String -> HttpT e r w s p m ()-comment msg = logNow $ L_Comment msg+comment msg = logNow LogInfo $ L_Comment msg -- | Pause the thread wait :: Int -- ^ milliseconds -> HttpT e r w s p m () wait k = do- logNow $ L_Pause k+ logNow LogInfo $ L_Pause k prompt $ ThreadDelay k -- | Write an entry to the log-logEntry- :: w- -> HttpT e r w s p m ()-logEntry = logNow . L_Log+logEntry :: LogSeverity -> w -> HttpT e r w s p m ()+logEntry severity = logNow severity . L_Log +-- | For debug level messages+logDebug :: w -> HttpT e r w s p m ()+logDebug = logEntry LogDebug +-- | For informational messages+logInfo :: w -> HttpT e r w s p m ()+logInfo = logEntry LogInfo +-- | For normal but significant conditions+logNotice :: w -> HttpT e r w s p m ()+logNotice = logEntry LogNotice++-- | For warning conditions+logWarning :: w -> HttpT e r w s p m ()+logWarning = logEntry LogWarning++-- | For error conditions+logError :: w -> HttpT e r w s p m ()+logError = logEntry LogError++-- | For critical conditions+logCritical :: w -> HttpT e r w s p m ()+logCritical = logEntry LogCritical++-- | Action must be taken immediately+logAlert :: w -> HttpT e r w s p m ()+logAlert = logEntry LogAlert++-- | System is unusable+logEmergency :: w -> HttpT e r w s p m ()+logEmergency = logEntry LogEmergency++-- | Set the severity level of all log actions in a session.+setLogSeverity+ :: LogSeverity+ -> HttpT e r w s p m a+ -> HttpT e r w s p m a+setLogSeverity severity = censor (W . map f . unW)+ where+ f :: LogEntry e w -> LogEntry e w+ f e = e { _logEntrySeverity = severity }+++ -- | Write a line to a handle hPutStrLn :: Handle@@ -875,11 +982,11 @@ httpGet url = do R{..} <- ask S{..} <- get- logNow $ L_Request GET url _httpOptions Nothing+ logNow LogDebug $ L_Request GET url _httpOptions Nothing result <- prompt $ HttpGet _httpOptions _httpSession url case result of Right response -> do- logNow $ L_Response response+ logNow LogDebug $ L_Response response return response Left err -> case _httpErrorInject err of Just z -> throwError z@@ -892,11 +999,11 @@ httpSilentGet url = do R{..} <- ask S{..} <- get- logNow L_SilentRequest+ logNow LogDebug L_SilentRequest result <- prompt $ HttpGet _httpOptions _httpSession url case result of Right response -> do- logNow L_SilentResponse+ logNow LogDebug L_SilentResponse return response Left err -> case _httpErrorInject err of Just z -> throwError z@@ -910,11 +1017,11 @@ httpPost url payload = do R{..} <- ask S{..} <- get- logNow $ L_Request POST url _httpOptions (Just payload)+ logNow LogDebug $ L_Request POST url _httpOptions (Just payload) result <- prompt $ HttpPost _httpOptions _httpSession url payload case result of Right response -> do- logNow $ L_Response response+ logNow LogDebug $ L_Response response return response Left err -> case _httpErrorInject err of Just z -> throwError z@@ -928,11 +1035,11 @@ httpSilentPost url payload = do R{..} <- ask S{..} <- get- logNow L_SilentRequest+ logNow LogDebug L_SilentRequest result <- prompt $ HttpPost _httpOptions _httpSession url payload case result of Right response -> do- logNow L_SilentResponse+ logNow LogDebug L_SilentResponse return response Left err -> case _httpErrorInject err of Just z -> throwError z@@ -945,11 +1052,11 @@ httpDelete url = do R{..} <- ask S{..} <- get- logNow $ L_Request DELETE url _httpOptions Nothing+ logNow LogDebug $ L_Request DELETE url _httpOptions Nothing result <- prompt $ HttpDelete _httpOptions _httpSession url case result of Right response -> do- logNow $ L_Response response+ logNow LogDebug$ L_Response response return response Left err -> case _httpErrorInject err of Just z -> throwError z@@ -962,11 +1069,11 @@ httpSilentDelete url = do R{..} <- ask S{..} <- get- logNow L_SilentRequest+ logNow LogDebug L_SilentRequest result <- prompt $ HttpDelete _httpOptions _httpSession url case result of Right response -> do- logNow L_SilentResponse+ logNow LogDebug L_SilentResponse return response Left err -> case _httpErrorInject err of Just z -> throwError z
+ src/Data/LogSeverity.hs view
@@ -0,0 +1,44 @@+{- |+Module : Data.LogSeverity+Description : Syslog-style log message severities+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++Syslog-style log message severities.+-}+++module Data.LogSeverity (+ LogSeverity(..)+ , colorBySeverity+) where++-- | [Syslog](https://en.wikipedia.org/wiki/Syslog) style log severities.+data LogSeverity+ = LogDebug -- ^ Debug-level messages+ | LogInfo -- ^ Informational messages+ | LogNotice -- ^ Normal but significant condition+ | LogWarning -- ^ Warning conditions+ | LogError -- ^ Error conditions+ | LogCritical -- ^ Critical conditions+ | LogAlert -- ^ Action must be taken immediately+ | LogEmergency -- ^ System is unusable+ deriving (Eq, Ord, Show)++-- | Pretty prints a simple log header.+colorBySeverity+ :: LogSeverity+ -> String -- ^ Printed before the severity label; i.e. a timestamp+ -> String+colorBySeverity severity msg = case severity of+ LogDebug -> "\x1b[1;32m" ++ msg ++ " DEBUG \x1b[0;39;49m"+ LogInfo -> "\x1b[1;32m" ++ msg ++ " INFO \x1b[0;39;49m"+ LogNotice -> "\x1b[1;34m" ++ msg ++ " NOTICE \x1b[0;39;49m"+ LogWarning -> "\x1b[1;33m" ++ msg ++ " WARNING \x1b[0;39;49m"+ LogError -> "\x1b[1;31m" ++ msg ++ " ERROR \x1b[0;39;49m"+ LogCritical -> "\x1b[1;31m" ++ msg ++ " CRITICAL \x1b[0;39;49m"+ LogAlert -> "\x1b[1;35m" ++ msg ++ " ALERT \x1b[0;39;49m"+ LogEmergency -> "\x1b[1;35m" ++ msg ++ " EMERGENCY \x1b[0;39;49m"
test/Control/Monad/Script/Http/Test.hs view
@@ -75,8 +75,8 @@ prop_httpSilentGet_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined , testProperty "throwError: is logged" $ prop_throwError_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined- , testProperty "logEntry: is logged" $- prop_logEntry_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "logDebug: is logged" $+ prop_logDebug_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined ] ] , localOption (QuickCheckTests num) $ testGroup "Real IO"@@ -432,18 +432,18 @@ catchError (throwError err) (\e -> if e == err then return k else return (k+1)) -prop_logEntry_write+prop_logDebug_write :: (Monad eff) => Proxy e -> Proxy r -> Proxy w -> Proxy s -> (forall u. P p u -> eff u) -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u)) -> Http e r w s p () -> s -> r -> w -> Property-prop_logEntry_write _ _ _ _ eval cond x s r w =+prop_logDebug_write _ _ _ _ eval cond x s r w = checkHttpM (basicState s) (noisyEnv r) eval cond (hasWorld $ outputContains "LOG") $ as x $ do- logEntry w+ logDebug w return () prop_logEntries_log@@ -457,10 +457,10 @@ checkHttpM (basicState s) (testEnv r) eval cond (hasLog $ \w -> [w1,w2,w3] == logEntries w) $ as x $ do- logEntry w1+ logDebug w1 comment "hey!"- logEntry w2- logEntry w3+ logDebug w2+ logDebug w3 return () prop_throwError_write
test/Control/Monad/Script/Test.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-} module Control.Monad.Script.Test ( tests ) where@@ -6,550 +6,134 @@ import Data.Proxy import Data.Functor.Classes import Data.Functor.Identity-import Data.Typeable-import Text.Show.Functions import Test.Tasty import Test.Tasty.QuickCheck+import Test.Tasty.QuickCheck.Laws import Control.Monad.Script ++ tests :: Int -> TestTree tests num = localOption (QuickCheckTests $ 10 * num) $- testGroup "Script"- [ test_script_properties- ]+ testGroup "Script Properties"+ [ testGroup "Monad Laws"+ [ testMonadLaws3 (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pS pU pS pQ pId) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pS pU pS pQ pMb) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pS pU pS pQ pEi) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testMonadLaws3 (pSc pU pS pU pS pQ pLs) (pSt pS pS) pU pB pI (scriptEq evalQ)+ ] + , testGroup "Applicative Laws"+ [ testApplicativeLaws3 (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pS pU pS pQ pId) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pS pU pS pQ pMb) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pS pU pS pQ pEi) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testApplicativeLaws3 (pSc pU pS pU pS pQ pLs) (pSt pS pS) pU pB pI (scriptEq evalQ)+ ] + , testGroup "Functor Laws"+ [ testFunctorLaws3 (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pS pU pS pQ pId) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pS pU pS pQ pMb) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pS pU pS pQ pEi) (pSt pS pS) pU pB pI (scriptEq evalQ)+ , testFunctorLaws3 (pSc pU pS pU pS pQ pLs) (pSt pS pS) pU pB pI (scriptEq evalQ)+ ] -as :: a -> a -> a-as _ a = a+ , testGroup "State Laws"+ [ testStateMonadLaws (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pS pU pS pQ pId) (pSt pS pS) pS pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pS pU pS pQ pMb) (pSt pS pS) pS pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pS pU pS pQ pEi) (pSt pS pS) pS pI (scriptEq evalQ) get put+ , testStateMonadLaws (pSc pU pS pU pS pQ pLs) (pSt pS pS) pS pI (scriptEq evalQ) get put+ ] + , testGroup "Reader Laws"+ [ testReaderMonadLaws (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pS pU pS pQ pId) (pSt pS pS) pS pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pS pU pS pQ pMb) (pSt pS pS) pS pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pS pU pS pQ pEi) (pSt pS pS) pS pU pB (scriptEq evalQ) ask local+ , testReaderMonadLaws (pSc pU pS pU pS pQ pLs) (pSt pS pS) pS pU pB (scriptEq evalQ) ask local+ ] + , testGroup "Writer"+ [ testGroup "Writer Laws"+ [ testWriterMonadLaws (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pS pS pS pQ pId) (pSt pS pS) pS pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pS pS pS pQ pMb) (pSt pS pS) pS pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pS pS pS pQ pEi) (pSt pS pS) pS pU pB (scriptEq evalQ) tell draft+ , testWriterMonadLaws (pSc pU pS pS pS pQ pLs) (pSt pS pS) pS pU pB (scriptEq evalQ) tell draft+ ] + , testGroup "Writer Equivalences"+ [ testWriterMonadEquivalences (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pS pS pS pQ pId) (pSt pS pS) pS pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pS pS pS pQ pMb) (pSt pS pS) pS pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pS pS pS pQ pEi) (pSt pS pS) pS pB (scriptEq evalQ) tell draft listen pass+ , testWriterMonadEquivalences (pSc pU pS pS pS pQ pLs) (pSt pS pS) pS pB (scriptEq evalQ) tell draft listen pass+ ]+ ]++ , testGroup "Error Laws"+ [ testErrorMonadLaws (pSc pU pU pU pU pQ pId) (pSt pU pU) pU pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pU pU pU pU pQ pMb) (pSt pU pU) pU pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pU pU pU pU pQ pEi) (pSt pU pU) pU pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pU pU pU pU pQ pLs) (pSt pU pU) pU pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pS pS pU pS pQ pId) (pSt pS pS) pS pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pS pS pU pS pQ pMb) (pSt pS pS) pS pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pS pS pU pS pQ pEi) (pSt pS pS) pS pB pI (scriptEq evalQ) throw catch+ , testErrorMonadLaws (pSc pS pS pU pS pQ pLs) (pSt pS pS) pS pB pI (scriptEq evalQ) throw catch+ ]+ ]++++-- | `ScriptT` values are pure, so we can test them for equality. scriptEq :: (Monad m, Eq a, Eq e, Eq s, Eq w, Eq1 m)- => s- -> r- -> (forall u. p u -> u)+ => (forall u. p u -> u)+ -> (s, r) -> ScriptT e r w s p m a -> ScriptT e r w s p m a -> Bool-scriptEq s r eval sc1 sc2 =+scriptEq eval (s,r) sc1 sc2 = liftEq (==) (execScriptT s r eval sc1) (execScriptT s r eval sc2) -prop_right_identity_law- :: (Monad m, Monoid w, Eq a, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w -> Proxy s- -> Proxy p -> Proxy a -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> ScriptT e r w s p m a -> Bool-prop_right_identity_law _ _ _ _ _ _ _ eval s r x =- scriptEq s r eval (x >>= return) x----prop_left_identity_law- :: (Monad m, Monoid w, Eq b, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> a -> (a -> ScriptT e r w s p m b) -> Bool-prop_left_identity_law _ _ _ _ _ _ _ _ eval s r a f =- scriptEq s r eval (return a >>= f) (f a)----prop_associativity_law- :: (Monad m, Monoid w, Eq c, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w -> Proxy s- -> Proxy p -> Proxy a -> Proxy b -> Proxy c -> Proxy m- -> (forall u. p u -> u)- -> s -> r- -> ScriptT e r w s p m a- -> (a -> ScriptT e r w s p m b)- -> (b -> ScriptT e r w s p m c)- -> Bool-prop_associativity_law _ _ _ _ _ _ _ _ _ eval s r x f g =- scriptEq s r eval ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))----prop_applicative_identity_law- :: (Monad m, Monoid w, Eq a, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> ScriptT e r w s p m a -> Bool-prop_applicative_identity_law _ _ _ _ _ _ _ eval s r x =- scriptEq s r eval (pure id <*> x) x----prop_applicative_hom_law- :: (Monad m, Monoid w, Eq a, Eq b, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> (a -> b) -> a -> ScriptT e r w s p m a -> Bool-prop_applicative_hom_law _ _ _ _ _ _ _ _ eval s r f a x =- scriptEq s r eval- (pure f <*> (as x $ pure a))- (pure (f a))----prop_applicative_interchange_law- :: (Monad m, Monoid w, Eq a, Eq b, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m- -> (forall u. p u -> u)- -> s -> r- -> ScriptT e r w s p m (a -> b)- -> a- -> ScriptT e r w s p m a -> Bool-prop_applicative_interchange_law _ _ _ _ _ _ _ _ eval s r u a x =- scriptEq s r eval- (u <*> (as x $ pure a))- (pure ($ a) <*> u)----prop_applicative_composition_law- :: (Monad m, Monoid w, Eq a, Eq b, Eq c, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy c -> Proxy m- -> (forall u. p u -> u)- -> s -> r- -> ScriptT e r w s p m (a -> b)- -> ScriptT e r w s p m (b -> c)- -> ScriptT e r w s p m a- -> Bool-prop_applicative_composition_law _ _ _ _ _ _ _ _ _ eval s r u v x =- scriptEq s r eval- (pure (.) <*> v <*> u <*> x)- (v <*> (u <*> x))----prop_tell_hom_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> w -> w -> ScriptT e r w s p m () -> Bool-prop_tell_hom_law _ _ _ _ _ _ eval s r w1 w2 x =- scriptEq s r eval- (as x (tell w1) >> as x (tell w2))- (as x (tell (mappend w1 w2)))----prop_listen_tell_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> w -> ScriptT e r w s p m () -> Bool-prop_listen_tell_law _ _ _ _ _ _ eval s r w x =- scriptEq s r eval- (listen (as x (tell w)))- ((as x (tell w)) >> return ((),w))----prop_censor_tell_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> (w -> w) -> w -> ScriptT e r w s p m () -> Bool-prop_censor_tell_law _ _ _ _ _ _ eval s r f w x =- scriptEq s r eval- (censor f (as x (tell w)))- (as x (tell (f w)))----prop_get_put_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> ScriptT e r w s p m s -> Bool-prop_get_put_law _ _ _ _ _ _ eval s r x =- scriptEq s r eval- ((as x get) >>= put)- (return ())----prop_put_put_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> s -> s -> ScriptT e r w s p m () -> Bool-prop_put_put_law _ _ _ _ _ _ eval s r u v x =- scriptEq s r eval- ((as x (put u)) >> put v)- (as x (put v))----prop_put_get_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> s -> ScriptT e r w s p m () -> Bool-prop_put_get_law _ _ _ _ _ _ eval s r u x =- scriptEq s r eval- ((as x (put u)) >> get)- ((as x (put u)) >> return u)----prop_put_modify_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> s -> (s -> s) -> ScriptT e r w s p m () -> Bool-prop_put_modify_law _ _ _ _ _ _ eval s r u f x =- scriptEq s r eval- ((as x (put u)) >> modify f)- ((as x (put $ f u)))----prop_put_modify'_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> s -> (s -> s) -> ScriptT e r w s p m () -> Bool-prop_put_modify'_law _ _ _ _ _ _ eval s r u f x =- scriptEq s r eval- ((as x (put u)) >> modify' f)- ((as x (put $ f u)))----prop_gets_modify_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq a, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m -> Proxy a- -> (forall u. p u -> u)- -> s -> r -> (s -> a) -> ScriptT e r w s p m a -> Bool-prop_gets_modify_law _ _ _ _ _ _ _ eval s r f x =- scriptEq s r eval- (gets f)- (as x (f <$> get))----prop_reader_ask_law- :: (Monad m, Monoid w, Eq e, Eq a, Eq s, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m -> Proxy a- -> (forall u. p u -> u)- -> s -> r -> (r -> a) -> ScriptT e r w s p m a -> Bool-prop_reader_ask_law _ _ _ _ _ _ _ eval s r f x =- scriptEq s r eval- (reader f)- (as x (f <$> ask))----prop_local_ask_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> (r -> r) -> ScriptT e r w s p m r -> Bool-prop_local_ask_law _ _ _ _ _ _ eval s r f x =- scriptEq s r eval- (as x (local f ask))- (as x (f <$> ask))----prop_throw_catch_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> e -> ScriptT e r w s p m e -> Bool-prop_throw_catch_law _ _ _ _ _ _ eval s r e x =- scriptEq s r eval- (as x (return e))- (as x (catch (throw e) return))----prop_catch_return_law- :: (Monad m, Monoid w, Eq e, Eq a, Eq s, Eq r, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy a -> Proxy m- -> (forall u. p u -> u)- -> s -> r -> a -> ScriptT e r w s p m a -> Bool-prop_catch_return_law _ _ _ _ _ _ _ eval s r a x =- scriptEq s r eval- (as x (return a))- (as x (catch (return a) undefined))----prop_throw_except_law- :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq a, Eq w, Eq1 m)- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m -> Proxy a- -> (forall u. p u -> u)- -> s -> r -> e -> ScriptT e r w s p m a -> Bool-prop_throw_except_law _ _ _ _ _ _ _ eval s r e x =- scriptEq s r eval- (as x (except $ Left e))- (as x (throw e))----prop_return_except_law- :: ( Monad m- , Monoid w- , Eq e, Eq s, Eq r, Eq a, Eq w- , Eq1 m- )- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m -> Proxy a- -> (forall u. p u -> u)- -> s -> r -> a -> ScriptT e r w s p m a -> Bool-prop_return_except_law _ _ _ _ _ _ _ eval s r a x =- scriptEq s r eval- (as x (except $ Right a))- (as x (return a))----prop_throw_triage_law- :: ( Monad m- , Monoid w- , Eq e, Eq s, Eq r, Eq a, Eq w- , Eq1 m- )- => Proxy e -> Proxy r -> Proxy w- -> Proxy s -> Proxy p -> Proxy m -> Proxy a- -> (forall u. p u -> u)- -> s -> r -> e -> (e -> e) -> ScriptT e r w s p m a -> Bool-prop_throw_triage_law _ _ _ _ _ _ _ eval s r e f x =- scriptEq s r eval- (as x (triage f $ throw e))- (as x (throw (f e)))----test_script_properties_for- :: ( Monad m- , Monoid w- , Eq a, Eq b, Eq c, Eq e, Eq s, Eq w, Eq r- , Eq1 m- , Show s, Show r, Show a, Show w, Show e- , Arbitrary s, Arbitrary r, Arbitrary a, Arbitrary b- , Arbitrary c, Arbitrary w, Arbitrary e- , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary w- , CoArbitrary s, CoArbitrary r, CoArbitrary e- , Typeable a, Typeable b, Typeable c, Typeable e, Typeable r- , Typeable w, Typeable s, Typeable p, Typeable m- )- => Proxy e -> Proxy r -> Proxy w -> Proxy s -> Proxy p- -> Proxy a -> Proxy b -> Proxy c -> Proxy m- -> (forall u. p u -> u)- -> TestTree-test_script_properties_for pe pr pw ps pp pa pb pc pm eval =- let- label = "Script: " ++- "E: " ++ show (typeRep pe) ++ " " ++- "R: " ++ show (typeRep pr) ++ " " ++- "W: " ++ show (typeRep pw) ++ " " ++- "S: " ++ show (typeRep ps) ++ " " ++- "P: " ++ show (typeRep pp) ++ ", " ++- "a: " ++ show (typeRep pa) ++ ", " ++- "b: " ++ show (typeRep pb) ++ ", " ++- "c: " ++ show (typeRep pc) ++ ", " ++- "m: " ++ show (typeRep pm)- in- testGroup label $- [ testGroup "Monad Laws"- [ testProperty "x >>= return === x" $- prop_right_identity_law pe pr pw ps pp pa pm eval- , testProperty "return a >>= f === f a" $- prop_left_identity_law pe pr pw ps pp pa pb pm eval- , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $- prop_associativity_law pe pr pw ps pp pa pb pc pm eval- ]- , testGroup "Applicative Laws"- [ testProperty "pure id <*> x === x" $- prop_applicative_identity_law pe pr pw ps pp pa pm eval- , testProperty "pure f <*> pure x === pure (f x)" $- prop_applicative_hom_law pe pr pw ps pp pa pb pm eval- , testProperty "u <*> pure x === pure ($ x) <*> u" $- prop_applicative_interchange_law pe pr pw ps pp pa pb pm eval- , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $- prop_applicative_composition_law pe pr pw ps pp pa pb pc pm eval- ]- , testGroup "Writer Laws"- [ testProperty "tell u >> tell v === tell (mappend u v)" $- prop_tell_hom_law pe pr pw ps pp pm eval- , testProperty "listen (tell w) === tell w >> return ((),w)" $- prop_listen_tell_law pe pr pw ps pp pm eval- , testProperty "censor f (tell w) === tell (f w)" $- prop_censor_tell_law pe pr pw ps pp pm eval- ]- , testGroup "State Laws"- [ testProperty "get >>= put === return ()" $- prop_get_put_law pe pr pw ps pp pm eval- , testProperty "put a >> put b === put b" $- prop_put_put_law pe pr pw ps pp pm eval- , testProperty "put s >> get === put s >> return s" $- prop_put_get_law pe pr pw ps pp pm eval- , testProperty "put s >> modify f === put (f s)" $- prop_put_modify_law pe pr pw ps pp pm eval- , testProperty "put s >> modify' f === put (f s)" $- prop_put_modify'_law pe pr pw ps pp pm eval- , testProperty "gets f === f <$> get" $- prop_gets_modify_law pe pr pw ps pp pm pa eval- ]- , testGroup "Reader Laws"- [ testProperty "reader f === f <$> ask" $- prop_reader_ask_law pe pr pw ps pp pm pa eval- , testProperty "local f ask === f <$> ask" $- prop_local_ask_law pe pr pw ps pp pm eval- ]- , testGroup "Error Laws"- [ testProperty "return e === catch (throw e) return" $- prop_throw_catch_law pe pr pw ps pp pm eval- , testProperty "except (Left e) === throw e" $- prop_throw_except_law pe pr pw ps pp pm pa eval- , testProperty "except (Right a) === return a" $- prop_return_except_law pe pr pw ps pp pm pa eval- , testProperty "catch (return a) undefined === return a" $- prop_catch_return_law pe pr pw ps pp pa pm eval- , testProperty "triage f (throw e) === throw (f e)" $- prop_throw_triage_law pe pr pw ps pp pm pa eval- ]- ]----test_script_properties :: TestTree-test_script_properties =- testGroup "Script Properties"- -- Identity- [ test_script_properties_for pU pU pU pU pQ pU pU pU pId evalQ- , test_script_properties_for pU pU pU pU pQ pB pB pB pId evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pI pId evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pB pId evalQ- , test_script_properties_for pU pU pU pU pQ pI pB pI pId evalQ- , test_script_properties_for pU pU pU pU pQ pB pI pI pId evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pS pId evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pI pId evalQ- , test_script_properties_for pU pU pU pU pQ pS pI pS pId evalQ- , test_script_properties_for pU pU pU pU pQ pI pS pS pId evalQ-- , test_script_properties_for pS pS pS pS pQ pU pU pU pId evalQ- , test_script_properties_for pS pS pS pS pQ pB pB pB pId evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pI pId evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pB pId evalQ- , test_script_properties_for pS pS pS pS pQ pI pB pI pId evalQ- , test_script_properties_for pS pS pS pS pQ pB pI pI pId evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pS pId evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pI pId evalQ- , test_script_properties_for pS pS pS pS pQ pS pI pS pId evalQ- , test_script_properties_for pS pS pS pS pQ pI pS pS pId evalQ-- -- Maybe- , test_script_properties_for pU pU pU pU pQ pU pU pU pMb evalQ- , test_script_properties_for pU pU pU pU pQ pB pB pB pMb evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pI pMb evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pB pMb evalQ- , test_script_properties_for pU pU pU pU pQ pI pB pI pMb evalQ- , test_script_properties_for pU pU pU pU pQ pB pI pI pMb evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pS pMb evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pI pMb evalQ- , test_script_properties_for pU pU pU pU pQ pS pI pS pMb evalQ- , test_script_properties_for pU pU pU pU pQ pI pS pS pMb evalQ-- , test_script_properties_for pS pS pS pS pQ pU pU pU pMb evalQ- , test_script_properties_for pS pS pS pS pQ pB pB pB pMb evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pI pMb evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pB pMb evalQ- , test_script_properties_for pS pS pS pS pQ pI pB pI pMb evalQ- , test_script_properties_for pS pS pS pS pQ pB pI pI pMb evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pS pMb evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pI pMb evalQ- , test_script_properties_for pS pS pS pS pQ pS pI pS pMb evalQ- , test_script_properties_for pS pS pS pS pQ pI pS pS pMb evalQ-- -- List- , test_script_properties_for pU pU pU pU pQ pU pU pU pLs evalQ- , test_script_properties_for pU pU pU pU pQ pB pB pB pLs evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pI pLs evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pB pLs evalQ- , test_script_properties_for pU pU pU pU pQ pI pB pI pLs evalQ- , test_script_properties_for pU pU pU pU pQ pB pI pI pLs evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pS pLs evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pI pLs evalQ- , test_script_properties_for pU pU pU pU pQ pS pI pS pLs evalQ- , test_script_properties_for pU pU pU pU pQ pI pS pS pLs evalQ-- , test_script_properties_for pS pS pS pS pQ pU pU pU pLs evalQ- , test_script_properties_for pS pS pS pS pQ pB pB pB pLs evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pI pLs evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pB pLs evalQ- , test_script_properties_for pS pS pS pS pQ pI pB pI pLs evalQ- , test_script_properties_for pS pS pS pS pQ pB pI pI pLs evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pS pLs evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pI pLs evalQ- , test_script_properties_for pS pS pS pS pQ pS pI pS pLs evalQ- , test_script_properties_for pS pS pS pS pQ pI pS pS pLs evalQ-- -- Either- , test_script_properties_for pU pU pU pU pQ pU pU pU pEi evalQ- , test_script_properties_for pU pU pU pU pQ pB pB pB pEi evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pI pEi evalQ- , test_script_properties_for pU pU pU pU pQ pI pI pB pEi evalQ- , test_script_properties_for pU pU pU pU pQ pI pB pI pEi evalQ- , test_script_properties_for pU pU pU pU pQ pB pI pI pEi evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pS pEi evalQ- , test_script_properties_for pU pU pU pU pQ pS pS pI pEi evalQ- , test_script_properties_for pU pU pU pU pQ pS pI pS pEi evalQ- , test_script_properties_for pU pU pU pU pQ pI pS pS pEi evalQ-- , test_script_properties_for pS pS pS pS pQ pU pU pU pEi evalQ- , test_script_properties_for pS pS pS pS pQ pB pB pB pEi evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pI pEi evalQ- , test_script_properties_for pS pS pS pS pQ pI pI pB pEi evalQ- , test_script_properties_for pS pS pS pS pQ pI pB pI pEi evalQ- , test_script_properties_for pS pS pS pS pQ pB pI pI pEi evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pS pEi evalQ- , test_script_properties_for pS pS pS pS pQ pS pS pI pEi evalQ- , test_script_properties_for pS pS pS pS pQ pS pI pS pEi evalQ- , test_script_properties_for pS pS pS pS pQ pI pS pS pEi evalQ- ]--- data Q a = Q a evalQ :: Q a -> a evalQ (Q a) = a pQ = Proxy :: Proxy Q+ pU = Proxy :: Proxy () pB = Proxy :: Proxy Bool pI = Proxy :: Proxy Int@@ -559,3 +143,13 @@ pMb = Proxy :: Proxy Maybe pLs = Proxy :: Proxy [] pEi = Proxy :: Proxy (Either Int)++pSc+ :: Proxy e -> Proxy r -> Proxy w -> Proxy s -> Proxy p -> Proxy m+ -> Proxy (ScriptT e r w s p m)+pSc _ _ _ _ _ _ = Proxy++pSt+ :: Proxy s -> Proxy r+ -> Proxy (s,r)+pSt _ _ = Proxy
test/Data/MockIO/Test.hs view
@@ -3,16 +3,11 @@ tests ) where -import Prelude hiding (lookup)-import Data.ByteString.Lazy (ByteString)-import Control.Exception (SomeException)-import System.IO (Handle, stdout, stderr) import Data.Proxy-import Data.Typeable-import Text.Show.Functions import Test.Tasty import Test.Tasty.QuickCheck+import Test.Tasty.QuickCheck.Laws import Data.MockIO.FileSystem import Control.Monad.Script.Http@@ -21,24 +16,62 @@ tests :: Int -> TestTree-tests num = localOption (QuickCheckTests $ 50 * num) $- testGroup "MockIO"- [ test_mockio_properties- , test_mocknet_properties+tests num =+ localOption (QuickCheckTests $ 50 * num) $+ testGroup "Mock"+ [ testGroup "MockIO"+ [ testGroup "Monad Laws"+ [ testMonadLaws3 (pMockIO pU) pU pU pB pI mockIOEq+ , testMonadLaws3 (pMockIO pB) pB pU pB pI mockIOEq+ , testMonadLaws3 (pMockIO pI) pI pU pB pI mockIOEq+ ]+ , testGroup "Applicative Laws"+ [ testApplicativeLaws3 (pMockIO pU) pU pU pB pI mockIOEq+ , testApplicativeLaws3 (pMockIO pB) pB pU pB pI mockIOEq+ , testApplicativeLaws3 (pMockIO pI) pI pU pB pI mockIOEq+ ]+ , testGroup "Functor Laws"+ [ testFunctorLaws3 (pMockIO pU) pU pU pB pI mockIOEq+ , testFunctorLaws3 (pMockIO pB) pB pU pB pI mockIOEq+ , testFunctorLaws3 (pMockIO pI) pI pU pB pI mockIOEq+ ]+ ]+ , testGroup "MockNet"+ [ testGroup "Monad Laws"+ [ testMonadLaws3 (pMockNet pU) pU pU pB pI mockNetEq+ , testMonadLaws3 (pMockNet pB) pB pU pB pI mockNetEq+ , testMonadLaws3 (pMockNet pI) pI pU pB pI mockNetEq+ ]+ , testGroup "Applicative Laws"+ [ testApplicativeLaws3 (pMockNet pU) pU pU pB pI mockNetEq+ , testApplicativeLaws3 (pMockNet pB) pB pU pB pI mockNetEq+ , testApplicativeLaws3 (pMockNet pI) pI pU pB pI mockNetEq+ ]+ , testGroup "Functor Laws"+ [ testFunctorLaws3 (pMockNet pU) pU pU pB pI mockNetEq+ , testFunctorLaws3 (pMockNet pB) pB pU pB pI mockNetEq+ , testFunctorLaws3 (pMockNet pI) pI pU pB pI mockNetEq+ ]+ ] ] -as :: x -> x -> x-as _ = id- pU = Proxy :: Proxy () pB = Proxy :: Proxy Bool pI = Proxy :: Proxy Int +pMockIO :: Proxy s -> Proxy (MockIO s)+pMockIO _ = Proxy +pMockWorld :: Proxy s -> Proxy (MockWorld s)+pMockWorld _ = Proxy +pMockNet :: Proxy s -> Proxy (MockNetwork s)+pMockNet _ = Proxy ++ mockIOEq :: (Eq s, Eq a) => s@@ -50,163 +83,6 @@ (runMockIO x $ basicMockWorld s) (runMockIO y $ basicMockWorld s) -test_mockio_properties :: TestTree-test_mockio_properties =- testGroup "MockIO Properties"- [ test_mockio_properties_for pU pU pU pU- , test_mockio_properties_for pB pB pB pB- , test_mockio_properties_for pI pI pI pI- ]--test_mockio_properties_for- :: ( Eq a, Eq b, Eq c, Eq s- , Show a, Show b, Show c, Show s- , Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary s- , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary s- , Typeable a, Typeable b, Typeable c, Typeable s- )- => Proxy a -> Proxy b -> Proxy c -> Proxy s -> TestTree-test_mockio_properties_for pa pb pc ps =- let- label = "MockIO: " ++- "s: " ++ show (typeRep ps) ++ " " ++- "a: " ++ show (typeRep pa) ++ " " ++- "b: " ++ show (typeRep pb) ++ " " ++- "c: " ++ show (typeRep pc)- in- testGroup label- [ testGroup "Monad Laws"- [ testProperty "x >>= return === x" $- prop_mockio_right_identity_law ps pa- , testProperty "return a >>= f === f a" $- prop_mockio_left_identity_law ps pa- , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $- prop_mockio_associativity_law pa pb pc ps- ]- , testGroup "Applicative Laws"- [ testProperty "pure id <*> x === x" $- prop_mockio_applicative_identity_law ps pa- , testProperty "pure f <*> pure x === pure (f x)" $- prop_mockio_applicative_hom_law ps pa pb- , testProperty "u <*> pure x === pure ($ x) <*> u" $- prop_mockio_applicative_interchange_law ps pa pb- , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $- prop_mockio_applicative_composition_law ps pa pb pc- ]- , testGroup "State Laws"- [ testProperty "get >>= put === return ()" $- prop_mockio_get_put_law ps- , testProperty "put s >> put t === put t" $- prop_mockio_put_put_law ps- , testProperty "put s >> get === put s >> return s" $- prop_mockio_put_get_law ps- , testProperty "put s >> modify f === put (f s)" $- prop_mockio_put_modify_law ps- ]- ]----prop_mockio_right_identity_law- :: (Eq s, Eq a)- => Proxy s -> Proxy a- -> s -> MockIO s a -> Bool-prop_mockio_right_identity_law _ _ s x =- mockIOEq s (x >>= return) x--prop_mockio_left_identity_law- :: (Eq s, Eq a)- => Proxy s -> Proxy a- -> s -> a -> (a -> MockIO s a) -> Bool-prop_mockio_left_identity_law _ _ s a f =- mockIOEq s (return a >>= f) (f a)--prop_mockio_associativity_law- :: (Eq s, Eq c)- => Proxy s -> Proxy a -> Proxy b -> Proxy c- -> s -> MockIO s a- -> (a -> MockIO s b)- -> (b -> MockIO s c)- -> Bool-prop_mockio_associativity_law _ _ _ _ s x f g =- mockIOEq s ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))--prop_mockio_get_put_law- :: (Eq s)- => Proxy s -> s -> MockIO s (MockWorld s) -> s -> Bool-prop_mockio_get_put_law _ u x s =- mockIOEq u ((as x getMockWorld) >>= putMockWorld) (return ())--prop_mockio_put_put_law- :: (Eq s)- => Proxy s -> s -> MockIO s () -> MockWorld s -> MockWorld s -> Bool-prop_mockio_put_put_law _ u x s t =- mockIOEq u- ((as x $ putMockWorld s) >> (putMockWorld t))- (putMockWorld t)--prop_mockio_put_get_law- :: (Eq s)- => Proxy s -> s -> MockWorld s -> MockIO s () -> Bool-prop_mockio_put_get_law _ s u x =- mockIOEq s- ((as x $ putMockWorld u) >> getMockWorld)- ((as x $ putMockWorld u) >> return u)--prop_mockio_put_modify_law- :: (Eq s)- => Proxy s -> s -> MockWorld s- -> (MockWorld s -> MockWorld s) -> MockIO s () -> Bool-prop_mockio_put_modify_law _ s u f x =- mockIOEq s- ((as x $ putMockWorld u) >> modifyMockWorld f)- ((as x $ putMockWorld $ f u))--prop_mockio_applicative_identity_law- :: (Eq a, Eq s)- => Proxy s -> Proxy a- -> s -> MockIO s a -> Bool-prop_mockio_applicative_identity_law _ _ s x =- mockIOEq s (pure id <*> x) x--prop_mockio_applicative_hom_law- :: (Eq b, Eq s)- => Proxy s -> Proxy a -> Proxy b- -> s -> (a -> b) -> a -> MockIO s a -> Bool-prop_mockio_applicative_hom_law _ _ _ s f a x =- mockIOEq s- (pure f <*> (as x $ pure a))- (pure (f a))--prop_mockio_applicative_interchange_law- :: (Eq a, Eq b, Eq s)- => Proxy s -> Proxy a -> Proxy b- -> s- -> MockIO s (a -> b)- -> a- -> MockIO s a -> Bool-prop_mockio_applicative_interchange_law _ _ _ s u a x =- mockIOEq s- (u <*> (as x $ pure a))- (pure ($ a) <*> u)--prop_mockio_applicative_composition_law- :: (Eq c, Eq s)- => Proxy s -> Proxy a -> Proxy b -> Proxy c- -> s- -> MockIO s (a -> b)- -> MockIO s (b -> c)- -> MockIO s a- -> Bool-prop_mockio_applicative_composition_law _ _ _ _ s u v x =- mockIOEq s- (pure (.) <*> v <*> u <*> x)- (v <*> (u <*> x))----- mockNetEq :: (Eq s, Eq a) => s@@ -222,155 +98,3 @@ (Right a1, Right a2) -> a1 == a2 && s1 == s2 (Left _, Left _) -> s1 == s2 _ -> False--test_mocknet_properties :: TestTree-test_mocknet_properties =- testGroup "MockNetwork"- [ test_mocknet_properties_for pU pU pU pU- , test_mocknet_properties_for pB pB pB pB- , test_mocknet_properties_for pI pI pI pI- ]--test_mocknet_properties_for- :: ( Eq a, Eq b, Eq c, Eq s- , Show a, Show b, Show c, Show s- , Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary s- , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary s- , Typeable a, Typeable b, Typeable c, Typeable s- )- => Proxy a -> Proxy b -> Proxy c -> Proxy s -> TestTree-test_mocknet_properties_for pa pb pc ps =- let- label = "MockIO: " ++- "s: " ++ show (typeRep ps) ++ " " ++- "a: " ++ show (typeRep pa) ++ " " ++- "b: " ++ show (typeRep pb) ++ " " ++- "c: " ++ show (typeRep pc)- in- testGroup label- [ testGroup "Monad Properties"- [ testProperty "x >>= return === x" $- prop_mocknet_right_identity_law ps pa- , testProperty "return a >>= f === f a" $- prop_mocknet_left_identity_law ps pa- , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $- prop_mocknet_associativity_law pa pb pc ps- ]- , testGroup "Applicative Properties"- [ testProperty "pure id <*> x === x" $- prop_mocknet_applicative_identity_law ps pa- , testProperty "pure f <*> pure x === pure (f x)" $- prop_mocknet_applicative_hom_law ps pa pb- , testProperty "u <*> pure x === pure ($ x) <*> u" $- prop_mocknet_applicative_interchange_law ps pa pb- , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $- prop_mocknet_applicative_composition_law ps pa pb pc- ]- , testGroup "State Properties"- [ testProperty "get >>= put === return ()" $- prop_mocknet_get_put_law ps- , testProperty "put s >> put t === put t" $- prop_mocknet_put_put_law ps- , testProperty "put s >> get === put s >> return s" $- prop_mocknet_put_get_law ps- , testProperty "put s >> modify f === put (f s)" $- prop_mocknet_put_modify_law ps- ]- ]----prop_mocknet_right_identity_law- :: (Eq s, Eq a)- => Proxy s -> Proxy a- -> s -> MockNetwork s a -> Bool-prop_mocknet_right_identity_law _ _ s x =- mockNetEq s (x >>= return) x--prop_mocknet_left_identity_law- :: (Eq s, Eq a)- => Proxy s -> Proxy a- -> s -> a -> (a -> MockNetwork s a) -> Bool-prop_mocknet_left_identity_law _ _ s a f =- mockNetEq s (return a >>= f) (f a)--prop_mocknet_associativity_law- :: (Eq s, Eq c)- => Proxy s -> Proxy a -> Proxy b -> Proxy c- -> s -> MockNetwork s a- -> (a -> MockNetwork s b)- -> (b -> MockNetwork s c)- -> Bool-prop_mocknet_associativity_law _ _ _ _ s x f g =- mockNetEq s ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))--prop_mocknet_get_put_law- :: (Eq s)- => Proxy s -> s -> MockNetwork s s -> s -> Bool-prop_mocknet_get_put_law _ u x s =- mockNetEq u ((as x getMockServer) >>= putMockServer) (return ())--prop_mocknet_put_put_law- :: (Eq s)- => Proxy s -> s -> MockNetwork s () -> s -> s -> Bool-prop_mocknet_put_put_law _ u x s t =- mockNetEq u- ((as x $ putMockServer s) >> (putMockServer t))- (putMockServer t)--prop_mocknet_put_get_law- :: (Eq s)- => Proxy s -> s -> s -> MockNetwork s () -> Bool-prop_mocknet_put_get_law _ s u x =- mockNetEq s- ((as x $ putMockServer u) >> getMockServer)- ((as x $ putMockServer u) >> return u)--prop_mocknet_put_modify_law- :: (Eq s)- => Proxy s -> s -> s -> (s -> s) -> MockNetwork s () -> Bool-prop_mocknet_put_modify_law _ s u f x =- mockNetEq s- ((as x $ putMockServer u) >> modifyMockServer f)- ((as x $ putMockServer $ f u))--prop_mocknet_applicative_identity_law- :: (Eq a, Eq s)- => Proxy s -> Proxy a- -> s -> MockNetwork s a -> Bool-prop_mocknet_applicative_identity_law _ _ s x =- mockNetEq s (pure id <*> x) x--prop_mocknet_applicative_hom_law- :: (Eq b, Eq s)- => Proxy s -> Proxy a -> Proxy b- -> s -> (a -> b) -> a -> MockNetwork s a -> Bool-prop_mocknet_applicative_hom_law _ _ _ s f a x =- mockNetEq s- (pure f <*> (as x $ pure a))- (pure (f a))--prop_mocknet_applicative_interchange_law- :: (Eq a, Eq b, Eq s)- => Proxy s -> Proxy a -> Proxy b- -> s- -> MockNetwork s (a -> b)- -> a- -> MockNetwork s a -> Bool-prop_mocknet_applicative_interchange_law _ _ _ s u a x =- mockNetEq s- (u <*> (as x $ pure a))- (pure ($ a) <*> u)--prop_mocknet_applicative_composition_law- :: (Eq c, Eq s)- => Proxy s -> Proxy a -> Proxy b -> Proxy c- -> s- -> MockNetwork s (a -> b)- -> MockNetwork s (b -> c)- -> MockNetwork s a- -> Bool-prop_mocknet_applicative_composition_law _ _ _ _ s u v x =- mockNetEq s- (pure (.) <*> v <*> u <*> x)- (v <*> (u <*> x))