packages feed

script-monad 0.0.3 → 0.0.4

raw patch · 13 files changed

+343/−163 lines, 13 filesdep ~QuickCheckdep ~aesondep ~aeson-pretty

Dependency ranges changed: QuickCheck, aeson, aeson-pretty, base, http-client, http-types, text, transformers, vector

Files

ChangeLog.md view
@@ -1,6 +1,25 @@ Changelog for script-monad ========================== +Unreleased Changes+------------------++++0.0.4+-----++* Added+    * `MonadFail` instances for `ScriptTT` and `HttpTT`+* Changed+    * `Eq` instance for `HttpResponse`; see https://github.com/snoyberg/http-client/issues/433+    * Relax types of `checkScriptTT` and `checkHttpTT`+    * Relax lower bounds of dependencies to support stack resolvers as old as lts-13.0. (This is a hard lower bound because we require QuantifiedConstraints.)+    * Support aeson-2.0.0.0 and http-client-0.7.0+    * Replace String with Text+++ 0.0.3 -----
README.md view
@@ -1,8 +1,6 @@ script-monad ============ -[![Build Status](https://travis-ci.org/nbloomf/script-monad.svg?branch=master)](https://travis-ci.org/nbloomf/script-monad)- Haskell library providing an unrolled stack of reader, writer, state, error, and prompt monads. Handy for designing extensible and testable DSLs.  As an example, also provides a basic monad transformer for HTTP interactions.
script-monad.cabal view
@@ -1,5 +1,5 @@ name:           script-monad-version:        0.0.3+version:        0.0.4 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@@ -26,21 +26,21 @@   hs-source-dirs: src    build-depends:-      base >=4.7 && <5+      base >=4.11.1.0 && <5 -    , aeson >=1.2.4.0-    , aeson-pretty >=0.8.5+    , aeson >=1.3.1.1+    , aeson-pretty >=0.8.7     , bytestring >=0.10.8.2-    , http-client >=0.5.10-    , http-types >=0.12.1+    , http-client >=0.5.14+    , http-types >=0.12.2     , lens >=4.16     , lens-aeson >=1.0.2-    , QuickCheck >=2.10.1-    , text >=1.2.3.0+    , QuickCheck >=2.11.3+    , text >=1.2.3.1     , time >=1.8.0.2-    , transformers >=0.5.2.0+    , transformers >=0.5.5.0     , unordered-containers >=0.2.9.0-    , vector >=0.12.0.1+    , vector >=0.12.0.2     , wreq >=0.5.2    exposed-modules:@@ -62,7 +62,7 @@   hs-source-dirs: app   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      base >=4.11.1.0 && <5     , script-monad  @@ -75,19 +75,24 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N    build-depends:-      base >=4.7 && <5+      base >=4.11.1.0 && <5     , script-monad      , bytestring >=0.10.8.2+    , http-client >=0.5.14+    , http-types >=0.12.2+    , QuickCheck >=2.12.6.1     , tasty >=1.0.1.1     , tasty-hunit >=0.10.0.1     , tasty-quickcheck >=0.9.2-    , tasty-quickcheck-laws >= 0.0.1+    , tasty-quickcheck-laws >=0.0.1+    , text >=1.2.3.1     , transformers >=0.5.2.0    other-modules:       Control.Monad.Script.Test     , Control.Monad.Script.Http.Test+    , Data.Text.Extras     , Data.MockIO.Test     , Data.MockIO.Test.Server     , Data.MockIO.FileSystem.Test
src/Control/Monad/Script.hs view
@@ -16,6 +16,7 @@  {-#   LANGUAGE+    CPP,     GADTs,     Rank2Types,     TupleSections, @@ -68,6 +69,10 @@   +#if MIN_VERSION_base(4,9,0)+import Prelude hiding (fail)+#endif+ import Control.Monad   ( ap, join ) import Control.Monad.Trans.Class@@ -83,14 +88,19 @@ import Data.Typeable   ( Typeable ) import Test.QuickCheck-  ( Property, Gen, Arbitrary(..), CoArbitrary(..) )+  ( Property, Gen, Arbitrary(..), CoArbitrary(..), Testable ) import Test.QuickCheck.Monadic-  ( monadicIO, run, assert )+  ( PropertyM, monadicIO, run, stop, assert ) +-- Transitional MonadFail implementation+#if MIN_VERSION_base(4,9,0)+import Control.Monad.Fail+#endif    + -- | Opaque stack of error (@e@), reader (@r@), writer (@w@), state (@s@), and prompt (@p@) monad transformers, accepting a monad transformer parameter (@t@). Behaves something like a monad transformer transformer. data   ScriptTT@@ -142,6 +152,11 @@     runScriptTT x (s0,r) g cont  instance+  (Monoid w, Monad eff, Monad (t eff), MonadTrans t, MonadFail (t eff))+    => MonadFail (ScriptTT e r w s p t eff) where+  fail msg = ScriptTT $ \_ -> \_ _ -> fail msg++instance   (Monoid w, Monad eff, Monad (t eff), MonadTrans t)     => Applicative (ScriptTT e r w s p t eff) where   pure = return@@ -201,18 +216,23 @@  -- | Turn a `ScriptTT` with a monadic evaluator into a `Property`; for testing with QuickCheck. Wraps `execScriptTT`. checkScriptTT-  :: (Monad eff, Monad (t eff), MonadTrans t, Show q)+  :: forall eff t q prop e r w s p a+   . (Monad eff, Monad (t eff), MonadTrans t, Show q, Testable prop)   => s -- ^ Initial state   -> r -- ^ Environment   -> (forall u. p u -> eff u) -- ^ Moandic effect evaluator   -> (t eff (Either e a, s, w) -> IO q) -- ^ Condense to `IO`-  -> (q -> Bool) -- ^ Result check+  -> (q -> prop) -- ^ Result check   -> ScriptTT e r w s p t eff a   -> Property-checkScriptTT s r eval cond check script = monadicIO $ do-  let result = execScriptTT s r eval script-  q <- run $ cond result-  assert $ check q+checkScriptTT s r eval cond check script =+  let+    action :: PropertyM IO prop+    action = do+      let result = execScriptTT s r eval script+      q <- run $ cond result+      stop $ check q+  in monadicIO action
src/Control/Monad/Script/Http.hs view
@@ -12,9 +12,11 @@  {-#   LANGUAGE+    CPP,     GADTs,     Rank2Types,     RecordWildCards,+    OverloadedStrings,     QuantifiedConstraints #-} @@ -38,7 +40,7 @@   , catchIOException   , catchAnyError   , printError-  , E()+  , E(..)    -- * Reader   , ask@@ -109,7 +111,13 @@   , checkHttpTT ) where +++#if MIN_VERSION_base(4,9,0)+import Prelude hiding (fail, lookup)+#else import Prelude hiding (lookup)+#endif  import Control.Applicative   ( Applicative(..), (<$>) )@@ -120,7 +128,7 @@ import Control.Exception   ( IOException, Exception, try ) import Control.Monad-  ( Functor(..), Monad(..), ap )+  ( Functor(..), Monad((>>=),return), ap ) import Control.Monad.Trans.Class   ( MonadTrans(..) ) import Control.Monad.Trans.Identity@@ -134,13 +142,11 @@ import Data.Aeson.Lens   ( _Value ) import Data.ByteString.Lazy-  ( ByteString, fromStrict, readFile, writeFile )+  ( ByteString, fromStrict, readFile, writeFile, toStrict ) import Data.ByteString.Lazy.Char8   ( unpack, pack ) import Data.Functor.Identity   ( Identity() )-import Data.HashMap.Strict-  ( lookup ) import Data.IORef   ( IORef, newIORef, readIORef, writeIORef ) import Data.List@@ -149,6 +155,9 @@   ( fromString ) import Data.Text   ( Text )+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T import Data.Time   ( UTCTime ) import Data.Time.Clock.System@@ -175,11 +184,25 @@ import System.IO.Error   ( ioeGetFileName, ioeGetLocation, ioeGetErrorString ) import Test.QuickCheck-  ( Property, Arbitrary(..), Gen )+  ( Property, Arbitrary(..), Gen, Testable )  import qualified Control.Monad.Script as S import Network.HTTP.Client.Extras import Data.Aeson.Extras++-- aeson 2.0.0.0 introduced KeyMap over HashMap+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key (fromText)+import Data.Aeson.KeyMap (lookup)+#else+import Data.HashMap.Strict (lookup)+#endif++-- Transitional MonadFail implementation+#if MIN_VERSION_base(4,9,0)+import Control.Monad.Fail+#endif+ import Data.LogSeverity import Data.MockIO import Data.MockIO.FileSystem@@ -212,6 +235,11 @@   (HttpTT x) >>= f = HttpTT (x >>= (httpTT . f))  instance+  (Monad eff, Monad (t eff), MonadTrans t, MonadFail (t eff))+    => MonadFail (HttpTT e r w s p t eff) where+  fail = HttpTT . fail++instance   (MonadTrans t, forall m. (Monad m) => Monad (t m))     => MonadTrans (HttpTT e r w s p t) where   lift = HttpTT . lift@@ -238,12 +266,13 @@  -- | Turn an `HttpTT` into a property; for testing with QuickCheck. checkHttpTT-  :: (Monad eff, Monad (t eff), MonadTrans t, Show q)+  :: forall eff t q e r w s p a prop+   . (Monad eff, Monad (t eff), MonadTrans t, Show q, Testable prop)   => S s -- ^ Initial state   -> R e w r -- ^ Environment   -> (forall u. P p u -> eff u) -- ^ Effect evaluator   -> (t eff (Either (E e) a, S s, W e w) -> IO q) -- ^ Condense to `IO`-  -> (q -> Bool) -- ^ Result check+  -> (q -> prop) -- ^ Result check   -> HttpTT e r w s p t eff a   -> Property checkHttpTT s r eval cond check =@@ -369,12 +398,12 @@   deriving Show  -- | Pretty printer for errors-printError :: (e -> String) -> E e -> String+printError :: (e -> Text) -> E e -> Text printError p err = case err of-  E_Http e -> unlines [ "HTTP Exception:", show e ]-  E_IO e -> unlines [ "IO Exception:", show e ]-  E_Json e -> unlines [ "JSON Error:", show e ]-  E e -> unlines [ "Error:", p e ]+  E_Http e -> T.unlines [ "HTTP Exception:", T.pack $ show e ]+  E_IO e -> T.unlines [ "IO Exception:", T.pack $ show e ]+  E_Json e -> T.unlines [ "JSON Error:", T.pack $ show e ]+  E e -> T.unlines [ "Error:", p e ]  -- | Also logs the exception. throwHttpException@@ -479,7 +508,7 @@   { _logOptions :: LogOptions e w    -- | Printer for log entries.-  , _logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe String+  , _logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text    -- | Handle for printing logs   , _logHandle :: Handle@@ -488,7 +517,7 @@   , _logLock :: Maybe (MVar ())    -- | Identifier string for the session; used to help match log entries emitted by the same session.-  , _uid :: String+  , _uid :: Text    -- | Function for elevating 'HttpException's to a client-supplied error type.   , _httpErrorInject :: HttpException -> Maybe e @@ -544,10 +573,10 @@   , _logHeaders :: Bool      -- | Printer for client-supplied error type. The boolean toggles JSON pretty printing.-  , _printUserError :: Bool -> e -> String+  , _printUserError :: Bool -> e -> Text      -- | Printer for client-supplied log type. the boolean toggles JSON pretty printing.-  , _printUserLog :: Bool -> w -> String+  , _printUserLog :: Bool -> w -> Text   }  -- | Noisy, in color, without parsing JSON responses, and using `Show` instances for user-supplied error and log types.@@ -558,8 +587,8 @@   , _logSilent = False   , _logMinSeverity = LogDebug   , _logHeaders = True-  , _printUserError = \_ e -> show e-  , _printUserLog = \_ w -> show w+  , _printUserError = \_ e -> T.pack $ show e+  , _printUserLog = \_ w -> T.pack $ show w   }  -- | Noisy, in color, without parsing JSON responses, and using trivial printers for user-supplied error and log types. For testing.@@ -578,20 +607,21 @@ basicLogEntryPrinter   :: LogOptions e w   -> LogEntry e w-  -> Maybe String+  -> Maybe Text basicLogEntryPrinter opt@LogOptions{..} LogEntry{..} =   if _logSilent || (_logEntrySeverity < _logMinSeverity)     then Nothing     else       let+        colorize :: Text -> Text         colorize msg = if _logColor           then colorBySeverity _logEntrySeverity msg           else msg -        timestamp :: String-        timestamp = take 19 $ show _logEntryTimestamp+        timestamp :: Text+        timestamp = T.pack $ take 19 $ show _logEntryTimestamp       in-        Just $ unwords $ filter (/= "")+        Just $ T.unwords $ filter (/= "")           [ colorize timestamp           , _logEntryUID           , logEntryTitle _logEntry@@ -614,14 +644,14 @@  data LogEntry e w = LogEntry   { _logEntryTimestamp :: UTCTime-  , _logEntryUID :: String+  , _logEntryUID :: Text   , _logEntrySeverity :: LogSeverity   , _logEntry :: Log e w   } deriving Show  -- | Log entry type data Log e w-  = L_Comment String+  = L_Comment Text   | L_Request HttpVerb Url Wreq.Options (Maybe ByteString)   | L_SilentRequest   | L_Response HttpResponse@@ -662,7 +692,7 @@   :: Handle   -> Maybe (MVar ())   -> LogOptions e w-  -> (LogOptions e w -> LogEntry e w -> Maybe String)+  -> (LogOptions e w -> LogEntry e w -> Maybe Text)   -> W e w   -> IO () printHttpLogs handle lock opts printer (W ws) = do@@ -672,8 +702,8 @@         Nothing -> return ()         Just str -> do           case lock of-            Just lock -> withMVar lock (\() -> System.IO.hPutStrLn handle str)-            Nothing -> System.IO.hPutStrLn handle str+            Just lock -> withMVar lock (\() -> T.hPutStrLn handle str)+            Nothing -> T.hPutStrLn handle str           hFlush handle    if _logSilent opts@@ -690,8 +720,8 @@   E_Json err -> L_JsonError err   E e -> L_Error e -type LogEntryTitle = String-type LogEntryBody = String+type LogEntryTitle = Text+type LogEntryBody = Text  logEntryBody   :: LogOptions e w@@ -702,65 +732,80 @@    L_Request verb url opt payload ->     let+      head :: Text       head = case (_logJson, _logHeaders) of-        (True,  True)  -> unpack $ encodePretty $ jsonResponseHeaders $ opt ^. Wreq.headers-        (False, True)  -> show $ opt ^. Wreq.headers+        (True,  True)  -> T.decodeUtf8 $ toStrict $+          encodePretty $ jsonResponseHeaders $ opt ^. Wreq.headers+        (False, True)  -> T.pack $ show $ opt ^. Wreq.headers         (_,     False) -> "" +      body :: Text       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)-        (False, Just p)  -> unpack p+          Nothing -> "JSON parse error:\n" <> T.decodeUtf8 (toStrict p)+          Just v -> T.decodeUtf8 $ toStrict $ encodePretty (v :: Value)+        (False, Just p)  -> T.decodeUtf8 $ toStrict p         (_,     Nothing) -> ""      in-      intercalate "\n" $ filter (/= "") [unwords ["Request", show verb, url], head, body]+      T.intercalate "\n" $ filter (/= "")+        [ T.unwords ["Request", T.pack $ show verb, url]+        , head+        , body+        ]    L_SilentRequest -> ""    L_Response response ->     let+      head :: Text       head = case (_logJson, _logHeaders) of-        (True,  True)  -> unpack $ encodePretty $ jsonResponseHeaders $ _responseHeaders response-        (False, True)  -> show $ _responseHeaders response+        (True,  True)  -> T.decodeUtf8 $ toStrict $+          encodePretty $ jsonResponseHeaders $ _responseHeaders response+        (False, True)  -> T.pack $ show $ _responseHeaders response         (_,     False) -> "" +      body :: Text       body = case _logJson of-        True  -> unpack $ encodePretty $ preview _Value $ _responseBody response-        False -> show response+        True  -> T.decodeUtf8 $ toStrict $+          encodePretty $ preview _Value $ _responseBody response+        False -> T.pack $ show response      in-      intercalate "\n" $ filter (/= "") ["Response", head, body]+      T.intercalate "\n" $ filter (/= "") ["Response", head, body]    L_SilentResponse -> "" -  L_Pause k -> "Wait for " ++ show k ++ "μs"+  L_Pause k -> "Wait for " <> T.pack (show k) <> "μs"    L_HttpError e -> if _logJson     then       let-        unpackHttpError :: HttpException -> Maybe (String, String)+        unpackHttpError :: HttpException -> Maybe (Text, Text)         unpackHttpError err = case err of           HttpExceptionRequest _ (StatusCodeException s r) -> do             json <- decode $ fromStrict r             let status = s ^. Wreq.responseStatus -            return (show status, unpack $ encodePretty (json :: Value))+            return (T.pack $ show status, T.decodeUtf8 $ toStrict $ encodePretty (json :: Value))           _ -> Nothing       in         case unpackHttpError e of-          Nothing -> show e-          Just (code, json) -> intercalate "\n" [ unwords [ "HTTP Error Response", code], json ]+          Nothing -> T.pack $ show e+          Just (code, json) -> T.intercalate "\n" [ T.unwords [ "HTTP Error Response", code], json ] -    else show e+    else T.pack $ show e -  L_IOError e -> unwords [ show $ ioeGetFileName e, ioeGetLocation e, ioeGetErrorString e ]+  L_IOError e -> T.unwords+    [ T.pack $ show $ ioeGetFileName e+    , T.pack $ ioeGetLocation e+    , T.pack $ ioeGetErrorString e+    ] -  L_JsonError e -> show e+  L_JsonError e -> T.pack $ show e -  L_Error e -> unwords [ _printUserError _logJson e ]+  L_Error e -> T.unwords [ _printUserError _logJson e ] -  L_Log w -> unwords [ _printUserLog _logJson w ]+  L_Log w -> T.unwords [ _printUserLog _logJson w ]   @@ -795,10 +840,10 @@ -- | Atomic effects data P p a where   HPutStrLn-    :: Handle -> String+    :: Handle -> Text     -> P p (Either IOException ())   HPutStrLnBlocking-    :: MVar () -> Handle -> String+    :: MVar () -> Handle -> Text     -> P p (Either IOException ())    GetSystemTime :: P p UTCTime@@ -823,28 +868,34 @@   -> IO a evalIO eval x = case x of   HPutStrLn handle string -> try $ do-    System.IO.hPutStrLn handle string+    T.hPutStrLn handle string     hFlush handle    HPutStrLnBlocking lock handle str -> try $ do-    withMVar lock (\() -> System.IO.hPutStrLn handle str)+    withMVar lock (\() -> T.hPutStrLn handle str)     hFlush handle    GetSystemTime -> fmap systemToUTCTime getSystemTime    ThreadDelay k -> threadDelay k -  HttpGet opts s url -> case s of-    Nothing -> try $ readHttpResponse <$> Wreq.getWith opts url-    Just sn -> try $ readHttpResponse <$> S.getWith opts sn url+  HttpGet opts s url ->+    let url' = T.unpack url+    in case s of+      Nothing -> try $ readHttpResponse <$> Wreq.getWith opts url'+      Just sn -> try $ readHttpResponse <$> S.getWith opts sn url' -  HttpPost opts s url msg -> case s of-    Nothing -> try $ readHttpResponse <$> Wreq.postWith opts url msg-    Just sn -> try $ readHttpResponse <$> S.postWith opts sn url msg+  HttpPost opts s url msg ->+    let url' = T.unpack url+    in case s of+      Nothing -> try $ readHttpResponse <$> Wreq.postWith opts url' msg+      Just sn -> try $ readHttpResponse <$> S.postWith opts sn url' msg -  HttpDelete opts s url -> case s of-    Nothing -> try $ readHttpResponse <$> Wreq.deleteWith opts url-    Just sn -> try $ readHttpResponse <$> S.deleteWith opts sn url+  HttpDelete opts s url ->+    let url' = T.unpack url+    in case s of+      Nothing -> try $ readHttpResponse <$> Wreq.deleteWith opts url'+      Just sn -> try $ readHttpResponse <$> S.deleteWith opts sn url'    P act -> eval act @@ -857,12 +908,12 @@   HPutStrLn handle str -> do     incrementTimer 1     fmap Right $ modifyMockWorld $ \w -> w-      { _files = appendLines (Right handle) (lines str) $ _files w }+      { _files = appendLines (Right handle) (T.lines str) $ _files w }    HPutStrLnBlocking _ handle str -> do     incrementTimer 1     fmap Right $ modifyMockWorld $ \w -> w-      { _files = appendLines (Right handle) (lines str) $ _files w }+      { _files = appendLines (Right handle) (T.lines str) $ _files w }    GetSystemTime -> do     incrementTimer 1@@ -918,7 +969,7 @@ -- | Write a comment to the log comment   :: (Monad eff, Monad (t eff), MonadTrans t)-  => String+  => Text   -> HttpTT e r w s p t eff () comment msg = logNow LogInfo $ L_Comment msg @@ -1002,7 +1053,7 @@ hPutStrLn   :: (Monad eff, Monad (t eff), MonadTrans t)   => Handle-  -> String+  -> Text   -> HttpTT e r w s p t eff () hPutStrLn h str = do   result <- prompt $ HPutStrLn h str@@ -1015,7 +1066,7 @@   :: (Monad eff, Monad (t eff), MonadTrans t)   => MVar ()   -> Handle-  -> String+  -> Text   -> HttpTT e r w s p t eff () hPutStrLnBlocking lock h str = do   result <- prompt $ HPutStrLnBlocking lock h str@@ -1153,9 +1204,16 @@   -> Value -- ^ JSON object   -> HttpTT e r w s p t eff Value lookupKeyJson key v = case v of-  Object obj -> case lookup key obj of-    Nothing -> throwJsonError $ JsonKeyDoesNotExist key (Object obj)-    Just value -> return value+  Object obj ->+    let+#if MIN_VERSION_aeson(2,0,0)+      val = lookup (fromText key) obj+#else+      val = lookup key obj+#endif+    in case val of+      Nothing -> throwJsonError $ JsonKeyDoesNotExist key (Object obj)+      Just value -> return value   _ -> throwJsonError $ JsonKeyLookupOffObject key v  -- | Decode a `A.Value` to some other type.
src/Data/Aeson/Extras.hs view
@@ -21,7 +21,7 @@ import Data.String   ( fromString ) import Data.Text-  ( Text )+  ( Text, pack ) import Test.QuickCheck   ( Arbitrary(..), Gen ) @@ -30,7 +30,7 @@ -- | Represents the kinds of errors that can occur when parsing and decoding JSON. data JsonError   -- | A generic JSON error; try not to use this.-  = JsonError String+  = JsonError Text   -- | A failed parse.   | JsonParseError ByteString   -- | An attempt to look up the value of a key that does not exist on an object.@@ -43,9 +43,10 @@  instance Arbitrary JsonError where   arbitrary = do+    let arbText = pack <$> arbitrary     k <- arbitrary :: Gen Int     case k `mod` 5 of-      0 -> JsonError <$> arbitrary+      0 -> JsonError <$> arbText       1 -> JsonParseError <$> (fromString <$> arbitrary)       2 -> JsonKeyDoesNotExist <$>              (fromString <$> arbitrary) <*>
src/Data/LogSeverity.hs view
@@ -11,11 +11,14 @@ -}  +{-# LANGUAGE OverloadedStrings #-} module Data.LogSeverity (     LogSeverity(..)   , colorBySeverity ) where +import Data.Text+ -- | [Syslog](https://en.wikipedia.org/wiki/Syslog) style log severities. data LogSeverity   = LogDebug -- ^ Debug-level messages@@ -31,14 +34,14 @@ -- | Pretty prints a simple log header. colorBySeverity   :: LogSeverity-  -> String -- ^ Printed before the severity label; i.e. a timestamp-  -> String+  -> Text -- ^ Printed before the severity label; i.e. a timestamp+  -> Text 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"+  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"
src/Data/MockIO.hs view
@@ -49,6 +49,8 @@   ( ap ) import Data.ByteString.Lazy   ( ByteString, pack )+import Data.Text+  ( Text ) import Data.Time   ( UTCTime(..), Day(..), diffTimeToPicoseconds ) import Data.Time.Clock@@ -115,9 +117,9 @@   { _files :: FileSystem (Either FilePath Handle)   , _time :: UTCTime -  , _httpGet :: String -> MockNetwork s HttpResponse-  , _httpPost :: String -> ByteString -> MockNetwork s HttpResponse-  , _httpDelete :: String -> MockNetwork s HttpResponse+  , _httpGet :: Text -> MockNetwork s HttpResponse+  , _httpPost :: Text -> ByteString -> MockNetwork s HttpResponse+  , _httpDelete :: Text -> MockNetwork s HttpResponse    , _serverState :: MockServer s   }
src/Data/MockIO/FileSystem.hs view
@@ -10,7 +10,7 @@ A fake filesystem for testing. -} -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module Data.MockIO.FileSystem (     FileSystem(..)   , File(..)@@ -26,21 +26,24 @@  import Data.Maybe import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T  import Test.QuickCheck-  ( Arbitrary(..), Positive(..), Gen, vectorOf )+  ( Arbitrary(..), Positive(..), Gen, vectorOf, listOf )    -- | Abstraction of a text file consisting of a "handle" and a list of lines. data File a = File   { _fileHandle :: a -- ^ File "handle"-  , _fileContents :: [String] -- ^ List of lines+  , _fileContents :: [Text] -- ^ List of lines   } deriving Eq  instance (Show a) => Show (File a) where-  show (File h lns) = unlines $-    [ ">>>>> " ++ show h ++ ":" ] ++ lns ++ ["<<<<<"]+  show (File h lns) = T.unpack $ T.unlines $+    [ ">>>>> " <> T.pack (show h) <> ":" ] ++ lns ++ ["<<<<<"]   @@ -62,7 +65,8 @@   arbitrary = do     Positive n <- arbitrary :: Gen (Positive Int)     handles <- fmap nub $ vectorOf (n `mod` 20) arbitrary-    FileSystem <$> mapM (\k -> File k <$> arbitrary ) handles+    let contents = listOf (fmap T.pack arbitrary)+    FileSystem <$> mapM (\k -> File k <$> contents ) handles  -- | No files; populate with `writeLines` or `appendLines`. emptyFileSystem :: FileSystem a@@ -102,7 +106,7 @@ hasFile   :: (Eq a)   => a -- ^ Handle-  -> [String] -- ^ Contents+  -> [Text] -- ^ Contents   -> FileSystem a   -> Bool hasFile h lns fs = case getLines h fs of@@ -114,14 +118,14 @@   :: (Eq a)   => a -- ^ Handle   -> FileSystem a-  -> Maybe [String]+  -> Maybe [Text] getLines h = fmap _fileContents . getFile h  -- | Overwrite the contents of a file. writeLines   :: (Eq a)   => a -- ^ Handle-  -> [String] -- ^ Contents+  -> [Text] -- ^ Contents   -> FileSystem a   -> FileSystem a writeLines a lns = putFile (File a lns)@@ -130,7 +134,7 @@ appendLines   :: (Eq a)   => a -- ^ Handle-  -> [String] -- ^ Contents+  -> [Text] -- ^ Contents   -> FileSystem a   -> FileSystem a appendLines h ls (FileSystem fs) = FileSystem $ appendLines' fs@@ -138,7 +142,7 @@     appendLines' zs = case zs of       [] -> [File h ls]       (File u ms):rest -> if u == h-        then (File u (ms ++ ls)) : rest+        then (File u (ms <> ls)) : rest         else (File u ms) : appendLines' rest  -- | Delete a file; if no such file exists, has no effect.@@ -162,7 +166,7 @@   -> e -- ^ EOF error   -> a -- ^ Handle   -> FileSystem a-  -> Either e (String, FileSystem a)+  -> Either e (Text, FileSystem a) readLine notFound eof k (FileSystem fs) = getline fs []   where     getline xs ys = case xs of
src/Network/HTTP/Client/Extras.hs view
@@ -10,7 +10,7 @@ HTTP helpers -} -{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, CPP #-} module Network.HTTP.Client.Extras (     Url   , HttpResponse(..)@@ -32,19 +32,35 @@   ( ByteString, unpack ) import Data.ByteString.Lazy   ( ByteString, unpack )+import Data.Text+  ( Text ) import Data.Vector   ( fromList ) import Network.HTTP.Client   ( HttpException(..), CookieJar, HttpExceptionContent(StatusCodeException)   , Response, responseCookieJar, responseBody, createCookieJar   , responseHeaders, responseVersion, responseStatus )++#if MIN_VERSION_http_client(0,7,0)+-- http-client 0.7.0 removed the Eq instance for CookieJar in favor+-- of multiple explicit equivalence relations.+import Network.HTTP.Client+  ( equalCookieJar )+#endif+ import Network.HTTP.Types import Data.Aeson (Value(..), object, (.=))++#if MIN_VERSION_aeson(2,0,0)+-- aeson 2.0.0.0 introduced KeyMap over HashMap+import Data.Aeson.Key (fromString)+#endif+ import qualified Data.Text as T (Text, pack)   -- | To make type signatures nicer-type Url = String+type Url = Text  -- | Non-opaque HTTP response type. data HttpResponse = HttpResponse@@ -53,8 +69,23 @@   , _responseHeaders :: ResponseHeaders   , _responseBody :: ByteString   , _responseCookieJar :: CookieJar-  } deriving (Eq, Show)+  } deriving (Show) +instance Eq HttpResponse where+  r1 == r2 = and+    [ (==)           (_responseStatus    r1) (_responseStatus    r2)+    , (==)           (_responseVersion   r1) (_responseVersion   r2)+    , (==)           (_responseHeaders   r1) (_responseHeaders   r2)+    , (==)           (_responseBody      r1) (_responseBody      r2)++#if MIN_VERSION_http_client(0,7,0)+    , equalCookieJar (_responseCookieJar r1) (_responseCookieJar r2)+#else+    , (==)           (_responseCookieJar r1) (_responseCookieJar r2)+#endif++    ]+ -- | Convert an opaque `Response ByteString` into an `HttpResponse`. readHttpResponse :: Response ByteString -> HttpResponse readHttpResponse r = HttpResponse@@ -72,7 +103,14 @@ jsonResponseHeaders =   Array . fromList . map (\(k,v) -> object [ (key k) .= (val v) ])   where-    key = T.pack . concatMap esc . show++    key =+#if MIN_VERSION_aeson(2,0,0)+      fromString . concatMap esc . show+#else+      T.pack . concatMap esc . show+#endif+     val = T.pack . concatMap esc . show      esc c = case c of
test/Control/Monad/Script/Http/Test.hs view
@@ -11,13 +11,23 @@ import Data.Proxy import Data.String import Data.ByteString.Lazy-  ( ByteString, pack )+  ( ByteString, pack, toStrict, fromChunks )+import Data.Text+  ( Text )+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Text.Extras import Data.Typeable import Data.List (isSuffixOf)+import Network.HTTP.Types+import Network.HTTP.Client+  ( HttpException(..), HttpExceptionContent(..) )  import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck+import Test.QuickCheck.Property+  ( failed, rejected )  import Control.Monad.Script.Http import Data.MockIO@@ -183,7 +193,7 @@   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))   -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> s -> r -> Text -> Property prop_comment_value _ _ _ _ eval cond x s r msg =   checkHttpTT (basicState s) (testEnv r) eval cond     (hasValue (== ())) $@@ -196,7 +206,7 @@   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))   -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> s -> r -> Text -> Property prop_comment_state _ _ _ _ eval cond x s r msg =   checkHttpTT (basicState s) (testEnv r) eval cond     (hasState (== s)) $@@ -209,9 +219,9 @@   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))   -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> s -> r -> Text -> Property prop_comment_write _ _ _ _ eval cond x s r str =-  let msg = filter (/= '\n') str in+  let msg = T.filter (/= '\n') str in   checkHttpTT (basicState s) (noisyEnv r) eval cond     (hasWorld $ outputContains msg) $     as x $ do@@ -223,9 +233,9 @@   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))   -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> s -> r -> Text -> Property prop_comment_silent _ _ _ _ eval cond x s r str =-  let msg = filter (/= '\n') str in+  let msg = T.filter (/= '\n') str in   checkHttpTT (basicState s) (testEnv r) eval cond     (hasWorld outputIsEmpty) $     as x $ do@@ -238,13 +248,13 @@ hasWorld p (_,w) = p w  outputContains-  :: String+  :: Text   -> MockWorld u   -> Bool outputContains str world =   case getLines (Right stdout) $ _files world of     Nothing -> False-    Just ls -> any (isSuffixOf str) ls+    Just ls -> any (T.isSuffixOf str) ls  outputIsEmpty   :: MockWorld u -> Bool@@ -286,7 +296,7 @@   -> s -> r -> Int -> Property prop_wait_write _ _ _ _ eval cond x s r k =   checkHttpTT (basicState s) (noisyEnv r) eval cond-    (hasWorld $ outputContains $ "Wait for " ++ show k ++ "μs") $+    (hasWorld $ outputContains $ "Wait for " <> T.pack (show k) <> "μs") $     as x $ do       wait k @@ -308,14 +318,14 @@   => Proxy e -> Proxy r -> Proxy w -> Proxy s   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))-  -> HttpT e r w s p eff ()+  -> HttpT e r w s p eff Int   -> s -> r -> Property prop_httpGet _ _ _ _ eval cond x s r =   checkHttpTT (basicState s) (testEnv r) eval cond-    (hasValue (== ())) $+    (hasValue (== 200)) $     as x $ do-      httpGet "http://example.com"-      return ()+      response <- httpGet "http://example.com"+      return (statusCode $ _responseStatus response)  prop_httpGet_json   :: (Monad eff, Show e, Show w, Show s, Show u)@@ -332,7 +342,7 @@         >>= (return . _responseBody)         >>= parseJson       val2 <- parseJson "{\"key\":\"value\"}"-      comment $ show $ val1 == val2+      comment $ T.pack $ show $ val1 == val2       return ()  prop_httpGet_write@@ -396,28 +406,30 @@   => Proxy e -> Proxy r -> Proxy w -> Proxy s   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))-  -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> HttpT e r w s p eff Int+  -> s -> r -> Text -> Property prop_httpPost _ _ _ _ eval cond x s r payload =   checkHttpTT (basicState s) (testEnv r) eval cond-    (hasValue (== ())) $+    (hasValue (== 200)) $     as x $ do-      httpPost "http://example.com" (fromString payload)-      return ()+      response <- httpPost "http://example.com" $+        fromChunks [T.encodeUtf8 payload]+      return (statusCode $ _responseStatus response)  prop_httpSilentPost   :: (Monad eff, Show e, Show w, Show s)   => Proxy e -> Proxy r -> Proxy w -> Proxy s   -> (forall u. P p u -> eff u)   -> (forall e s w t. IdentityT eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))-  -> HttpT e r w s p eff ()-  -> s -> r -> String -> Property+  -> HttpT e r w s p eff Int+  -> s -> r -> Text -> Property prop_httpSilentPost _ _ _ _ eval cond x s r payload =   checkHttpTT (basicState s) (testEnv r) eval cond-    (hasValue (== ())) $+    (hasValue (== 200)) $     as x $ do-      httpSilentPost "http://example.com" (fromString payload)-      return ()+      response <- httpSilentPost "http://example.com" $+        fromChunks [T.encodeUtf8 payload]+      return (statusCode $ _responseStatus response)  prop_throwError   :: (Monad eff, Eq e, Show e, Show w, Show s)@@ -521,12 +533,21 @@       lookupKeyJson "key" obj >>= constructFromJson  hasValue-  :: (t -> Bool)+  :: (Show e) => (t -> Bool)   -> (Either (E e) t, S s, W e w)-  -> Bool+  -> Property hasValue p (x,_,_) = case x of-  Left e -> False-  Right a -> p a+  Left (E_Http (HttpExceptionRequest _ err)) ->+    case err of+      -- These errors are outside the control of this code, so it's better+      -- to reject cases that trigger them than to fail the whole suite.+      ConnectionTimeout -> property rejected+      InternalException _ -> property rejected++      -- These might be real errors. :)+      e -> counterexample (show e) failed+  Left e -> counterexample (show e) failed+  Right a -> property $ p a  hasLog   :: (W e w -> Bool)
test/Data/MockIO/FileSystem/Test.hs view
@@ -4,10 +4,14 @@  import Data.Proxy   ( Proxy(..) )+import Data.Text+  ( Text )  import Test.Tasty import Test.Tasty.QuickCheck +import Data.Text.Extras+ import Data.MockIO.FileSystem  tests :: Int -> TestTree@@ -66,31 +70,31 @@   if (x == y) && (y == z) then x == z else True  prop_appendLines_not_equal-  :: (Eq a) => Proxy a -> a -> String -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> Text -> FileSystem a -> Bool prop_appendLines_not_equal _ h lns fs =   fs /= appendLines h [lns] fs  prop_writeLines_lzero-  :: (Eq a) => Proxy a -> a -> [String] -> [String] -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> [Text] -> [Text] -> FileSystem a -> Bool prop_writeLines_lzero _ h ls ms fs =   (writeLines h ls fs) == (writeLines h ls $ writeLines h ms fs)  prop_writeLines_fileExists-  :: (Eq a) => Proxy a -> a -> [String] -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> [Text] -> FileSystem a -> Bool prop_writeLines_fileExists _ h lns fs =   fileExists h $ writeLines h lns fs  prop_hasFile_writeLines-  :: (Eq a) => Proxy a -> a -> [String] -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> [Text] -> FileSystem a -> Bool prop_hasFile_writeLines _ h lns fs =   hasFile h lns $ writeLines h lns fs  prop_appendLines_writeLines-  :: (Eq a) => Proxy a -> a -> [String] -> [String] -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> [Text] -> [Text] -> FileSystem a -> Bool prop_appendLines_writeLines _ h as bs fs =   (==)     (appendLines h bs $ writeLines h as fs)-    (writeLines h (as ++ bs) fs)+    (writeLines h (as <> bs) fs)  prop_deleteFile_idempotent   :: (Eq a) => Proxy a -> a -> FileSystem a -> Bool@@ -120,7 +124,7 @@     Just ms -> hasFile h ms fs  prop_readLine_writeLines-  :: (Eq a) => Proxy a -> a -> String -> FileSystem a -> Bool+  :: (Eq a) => Proxy a -> a -> Text -> FileSystem a -> Bool prop_readLine_writeLines _ h str fs =   case readLine () () h $ writeLines h [str] fs of     Left _ -> False
+ test/Data/Text/Extras.hs view
@@ -0,0 +1,7 @@+module Data.Text.Extras where++import Data.Text+import Test.QuickCheck++instance Arbitrary Text where+  arbitrary = pack <$> arbitrary