unbeliever 0.10.0.8 → 0.11.0.1
raw patch · 10 files changed
+561/−485 lines, 10 filesdep +asyncdep +core-telemetrydep +stmdep ~core-datadep ~core-programdep ~core-text
Dependencies added: async, core-telemetry, stm
Dependency ranges changed: core-data, core-program, core-text
Files
- LICENSE +16/−29
- tests/CheckArgumentsParsing.hs +120/−121
- tests/CheckContainerBehaviour.hs +33/−33
- tests/CheckJsonWrapper.hs +35/−27
- tests/CheckProgramMonad.hs +53/−53
- tests/CheckRopeBehaviour.hs +187/−169
- tests/CheckTelemetryMachinery.hs +95/−0
- tests/Everything.hs +0/−26
- tests/TestSuite.hs +3/−0
- unbeliever.cabal +19/−27
LICENSE view
@@ -1,32 +1,19 @@-Opinionated Haskell Interoperability--Copyright © 2018-2019 Athae Eredh Siniath and Others-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:+Copyright © 2018-2021 Athae Eredh Siniath and Others - 1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following conditions: - 2. Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.- - 3. Neither the name of the project nor the names of its contributors- may be used to endorse or promote products derived from this - software without specific prior written permission.+The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
tests/CheckArgumentsParsing.hs view
@@ -2,11 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module CheckArgumentsParsing- ( checkArgumentsParsing,+module CheckArgumentsParsing (+ checkArgumentsParsing, main,- )-where+) where import Core.Program.Arguments import Core.System.Base@@ -14,151 +13,151 @@ main :: IO () main = do- finally (hspec checkArgumentsParsing) (putStrLn ".")+ finally (hspec checkArgumentsParsing) (putStrLn ".") options1 :: [Options] options1 =- [ Option "verbose" (Just 'v') Empty "Make the program verbose",- Option "quiet" (Just 'q') Empty "Be very very quiet, we're hunting wabbits",- Option "dry-run" Nothing (Value "WHEN") "Before trapping Road Runner, best to do a dry-run"- ]+ [ Option "verbose" (Just 'v') Empty "Make the program verbose"+ , Option "quiet" (Just 'q') Empty "Be very very quiet, we're hunting wabbits"+ , Option "dry-run" Nothing (Value "WHEN") "Before trapping Road Runner, best to do a dry-run"+ ] options2 :: [Options] options2 =- [ Option "recursive" Nothing Empty "Descend into darkness",- Argument "filename" "The file that you want"- ]+ [ Option "recursive" Nothing Empty "Descend into darkness"+ , Argument "filename" "The file that you want"+ ] options3 :: [Options] options3 =- [ Option "all" (Just 'a') Empty "Good will to everyone"- ]+ [ Option "all" (Just 'a') Empty "Good will to everyone"+ ] commands1 :: [Commands] commands1 =- [ Global- options1,- Command- "add"- "Add a new file"- options2- ]+ [ Global+ options1+ , Command+ "add"+ "Add a new file"+ options2+ ] commands2 :: [Commands] commands2 =- [ Global- options1,- Command- "add"- "Add a new file"- options2,- Command- "commit"- "Commit for eternity"- options3- ]+ [ Global+ options1+ , Command+ "add"+ "Add a new file"+ options2+ , Command+ "commit"+ "Commit for eternity"+ options3+ ] checkArgumentsParsing :: Spec checkArgumentsParsing = do- describe "Parsing of simple command-lines" $ do- it "recognizes a single specified options" $- let config = simple options1- actual = parseCommandLine config ["--verbose"]- expect = Parameters Nothing [("verbose", Empty)] []- in actual `shouldBe` Right expect- it "recognizes all specified options" $- let config = simple options1- actual = parseCommandLine config ["--verbose", "--quiet", "--dry-run=Tomorrow"]- expect =- Parameters- Nothing- [ ("verbose", Empty),- ("quiet", Empty),- ("dry-run", Value "Tomorrow")- ]- []- in actual `shouldBe` Right expect+ describe "Parsing of simple command-lines" $ do+ it "recognizes a single specified options" $+ let config = simpleConfig options1+ actual = parseCommandLine config ["--verbose"]+ expect = Parameters Nothing [("verbose", Empty)] []+ in actual `shouldBe` Right expect+ it "recognizes all specified options" $+ let config = simpleConfig options1+ actual = parseCommandLine config ["--verbose", "--quiet", "--dry-run=Tomorrow"]+ expect =+ Parameters+ Nothing+ [ ("verbose", Empty)+ , ("quiet", Empty)+ , ("dry-run", Value "Tomorrow")+ ]+ []+ in actual `shouldBe` Right expect - it "recognizes required arguments" $- let config = simple options2- actual = parseCommandLine config ["hello.txt"]- expect =- Parameters- Nothing- [ ("filename", Value "hello.txt")- ]- []- in actual `shouldBe` Right expect+ it "recognizes required arguments" $+ let config = simpleConfig options2+ actual = parseCommandLine config ["hello.txt"]+ expect =+ Parameters+ Nothing+ [ ("filename", Value "hello.txt")+ ]+ []+ in actual `shouldBe` Right expect - it "handles valued parameter" $- let config = simple options2- actual = parseCommandLine config ["hello.txt"]- expect =- Parameters- Nothing- [ ("filename", Value "hello.txt")- ]- []- in actual `shouldBe` Right expect+ it "handles valued parameter" $+ let config = simpleConfig options2+ actual = parseCommandLine config ["hello.txt"]+ expect =+ Parameters+ Nothing+ [ ("filename", Value "hello.txt")+ ]+ []+ in actual `shouldBe` Right expect - it "rejects unknown options" $- let config = simple options2- actual = parseCommandLine config ["-a"]- in actual `shouldBe` Left (UnknownOption "-a")+ it "rejects unknown options" $+ let config = simpleConfig options2+ actual = parseCommandLine config ["-a"]+ in actual `shouldBe` Left (UnknownOption "-a") - it "rejects a malformed option" $- let config = simple options2- actual = parseCommandLine config ["-help"]- in actual `shouldBe` Left (InvalidOption "-help")+ it "rejects a malformed option" $+ let config = simpleConfig options2+ actual = parseCommandLine config ["-help"]+ in actual `shouldBe` Left (InvalidOption "-help") - it "fails on missing argument" $- let config = simple options2- actual = parseCommandLine config []- in actual `shouldBe` Left (MissingArgument "filename")+ it "fails on missing argument" $+ let config = simpleConfig options2+ actual = parseCommandLine config []+ in actual `shouldBe` Left (MissingArgument "filename") - it "accepts request for version" $- let config = simple options1- actual = parseCommandLine config ["--version"]- in actual `shouldBe` Left VersionRequest+ it "accepts request for version" $+ let config = simpleConfig options1+ actual = parseCommandLine config ["--version"]+ in actual `shouldBe` Left VersionRequest - describe "Parsing of complex command-lines" $ do- it "recognizes only single command" $- let config = complex commands1- actual = parseCommandLine config ["-q", "add", "--recursive", "Hello.hs"]- expect =- Parameters- (Just "add")- [ ("quiet", Empty),- ("recursive", Empty),- ("filename", Value "Hello.hs")- ]- []- in actual `shouldBe` Right expect+ describe "Parsing of complex command-lines" $ do+ it "recognizes only single command" $+ let config = complexConfig commands1+ actual = parseCommandLine config ["-q", "add", "--recursive", "Hello.hs"]+ expect =+ Parameters+ (Just "add")+ [ ("quiet", Empty)+ , ("recursive", Empty)+ , ("filename", Value "Hello.hs")+ ]+ []+ in actual `shouldBe` Right expect - it "fails on missing command" $- let config = complex commands1- actual = parseCommandLine config []- in actual `shouldBe` Left (NoCommandFound)+ it "fails on missing command" $+ let config = complexConfig commands1+ actual = parseCommandLine config []+ in actual `shouldBe` Left (NoCommandFound) - it "rejects an unknown command" $- let config = complex commands1- actual = parseCommandLine config ["launch"]- in actual `shouldBe` Left (UnknownCommand "launch")+ it "rejects an unknown command" $+ let config = complexConfig commands1+ actual = parseCommandLine config ["launch"]+ in actual `shouldBe` Left (UnknownCommand "launch") - it "recognizes different command" $ -- ie, now from among multiple choices- let config = complex commands2- actual = parseCommandLine config ["commit"]- expect = Parameters (Just "commit") [] []- in actual `shouldBe` Right expect+ it "recognizes different command" $ -- ie, now from among multiple choices+ let config = complexConfig commands2+ actual = parseCommandLine config ["commit"]+ expect = Parameters (Just "commit") [] []+ in actual `shouldBe` Right expect - it "rejects further trailing arguments" $- let config = complex commands2- actual = parseCommandLine config ["commit", "some"]- in actual `shouldBe` Left (UnexpectedArguments ["some"])+ it "rejects further trailing arguments" $+ let config = complexConfig commands2+ actual = parseCommandLine config ["commit", "some"]+ in actual `shouldBe` Left (UnexpectedArguments ["some"]) - -- in complex mode wasn't accpting --version as a global option.+ -- in complex mode wasn't accpting --version as a global option. - it "accepts request for version" $- let config = complex commands2- actual = parseCommandLine config ["--version"]- in actual `shouldBe` Left VersionRequest+ it "accepts request for version" $+ let config = complexConfig commands2+ actual = parseCommandLine config ["--version"]+ in actual `shouldBe` Left VersionRequest
tests/CheckContainerBehaviour.hs view
@@ -18,42 +18,42 @@ checkContainerBehaviour :: Spec checkContainerBehaviour = do- describe "Set data type" $ do- it "calculates length accurately" $ do- length fibonacci `shouldBe` 8- let s = intoSet fibonacci- length s `shouldBe` 7+ describe "Set data type" $ do+ it "calculates length accurately" $ do+ length fibonacci `shouldBe` 8+ let s = intoSet fibonacci+ length s `shouldBe` 7 - it "converts to list in Ord order" $ do- let s = intoSet climbing- length s `shouldBe` 5- fromSet s `shouldBe` [1, 2, 3, 4, 9]+ it "converts to list in Ord order" $ do+ let s = intoSet climbing+ length s `shouldBe` 5+ fromSet s `shouldBe` [1, 2, 3, 4, 9] - describe "Map data type" $ do- it "calculates length accurately" $ do- length introduction `shouldBe` 3- let p = intoMap introduction- length p `shouldBe` 3+ describe "Map data type" $ do+ it "calculates length accurately" $ do+ length introduction `shouldBe` 3+ let p = intoMap introduction+ length p `shouldBe` 3 - it "values can be looked up" $ do- let p = intoMap introduction- containsKey 3 p `shouldBe` True- lookupKeyValue 3 p `shouldBe` (Just "world")- containsKey 4 p `shouldBe` False- lookupKeyValue 4 p `shouldBe` Nothing+ it "values can be looked up" $ do+ let p = intoMap introduction+ containsKey 3 p `shouldBe` True+ lookupKeyValue 3 p `shouldBe` (Just "world")+ containsKey 4 p `shouldBe` False+ lookupKeyValue 4 p `shouldBe` Nothing - it "values can be inserted into Map" $ do- let p = intoMap introduction- let p' = insertKeyValue 4 "!" p- containsKey 4 p' `shouldBe` True- lookupKeyValue 4 p' `shouldBe` (Just "!")+ it "values can be inserted into Map" $ do+ let p = intoMap introduction+ let p' = insertKeyValue 4 "!" p+ containsKey 4 p' `shouldBe` True+ lookupKeyValue 4 p' `shouldBe` (Just "!") - it "converts to list in Ord order" $ do- let p = intoMap introduction- fromMap p `shouldBe` [(1, "hello"), (2, " "), (3, "world")]+ it "converts to list in Ord order" $ do+ let p = intoMap introduction+ fromMap p `shouldBe` [(1, "hello"), (2, " "), (3, "world")] - it "updated values supercede existing values" $ do- let p = intoMap introduction- let p' = insertKeyValue 2 "&" p- containsKey 2 p' `shouldBe` True- lookupKeyValue 2 p' `shouldBe` (Just "&")+ it "updated values supercede existing values" $ do+ let p = intoMap introduction+ let p' = insertKeyValue 2 "&" p+ containsKey 2 p' `shouldBe` True+ lookupKeyValue 2 p' `shouldBe` (Just "&")
tests/CheckJsonWrapper.hs view
@@ -6,7 +6,6 @@ import Core.Data import Core.Encoding.Json import Core.Text-import qualified Data.ByteString.Char8 as C import Test.Hspec k = JsonKey "intro"@@ -16,39 +15,48 @@ j = JsonObject (intoMap [(k, v)]) j2 =- JsonObject- ( intoMap- [ (JsonKey "song", JsonString "Thriller"),- (JsonKey "other", JsonString "A very long name for the \"shadow of the moon\"."),- ( JsonKey "four",- JsonObject- ( intoMap- [ (JsonKey "n1", r)- ]- )- )- ]- )+ JsonObject+ ( intoMap+ [ (JsonKey "song", JsonString "Thriller")+ , (JsonKey "other", JsonString "A very long name for the \"shadow of the moon\".")+ , (JsonKey "answer", JsonNumber 42)+ , (JsonKey "pie", JsonNumber 6.62607015e-34)+ ,+ ( JsonKey "four"+ , JsonObject+ ( intoMap+ [ (JsonKey "n1", r)+ ]+ )+ )+ ]+ ) -b = intoBytes (C.pack "{\"cost\": 4500}")+b = packBytes "{\"cost\": 4500}" r = JsonArray [JsonBool False, JsonNull, JsonNumber 42] checkJsonWrapper :: Spec checkJsonWrapper = do- describe "JsonValue encoding" $- do- it "JSON String should be wrapped in quotes" $ do- encodeToUTF8 v `shouldBe` intoBytes (C.pack "\"Hello\"")+ describe "JsonValue encoding" $+ do+ it "JSON String should be wrapped in quotes" $ do+ encodeToUTF8 v `shouldBe` packBytes "\"Hello\"" - it "JSON Array renders correctly" $ do- encodeToUTF8 r `shouldBe` intoBytes (C.pack "[false,null,42]")+ it "JSON Numbers differentiate between integers and floats" $ do+ encodeToUTF8 (JsonNumber 42) `shouldBe` packBytes "42"+ encodeToUTF8 (JsonNumber 3.141592) `shouldBe` packBytes "3.141592"+ encodeToUTF8 (JsonNumber 2.99792458e8) `shouldBe` packBytes "299792458"+ encodeToUTF8 (JsonNumber 6.62607015e-34) `shouldBe` packBytes "6.62607015e-34" - it "JSON Object renders correctly" $ do- encodeToUTF8 j `shouldBe` intoBytes (C.pack "{\"intro\":\"Hello\"}")+ it "JSON Array renders correctly" $ do+ encodeToUTF8 r `shouldBe` packBytes "[false,null,42]" - it "decoding an Object parses" $ do- decodeFromUTF8 b `shouldBe` Just (JsonObject (intoMap [(JsonKey "cost", JsonNumber 4500)]))+ it "JSON Object renders correctly" $ do+ encodeToUTF8 j `shouldBe` packBytes "{\"intro\":\"Hello\"}" - it "complex JSON Object round trips" $ do- decodeFromUTF8 (encodeToUTF8 j2) `shouldBe` Just j2+ it "decoding an Object parses" $ do+ decodeFromUTF8 b `shouldBe` Just (JsonObject (intoMap [(JsonKey "cost", JsonNumber 4500)]))++ it "complex JSON Object round trips" $ do+ decodeFromUTF8 (encodeToUTF8 j2) `shouldBe` Just j2
tests/CheckProgramMonad.hs view
@@ -14,21 +14,21 @@ options :: [Options] options =- [ Option "all" (Just 'a') Empty "Good will to everyone"- ]+ [ Option "all" (Just 'a') Empty "Good will to everyone"+ ] commands :: [Commands] commands =- [ Global- options,- Command- "go-forth"- "And multiply"- []- ]+ [ Global+ options+ , Command+ "go-forth"+ "And multiply"+ []+ ] data Boom = Boom- deriving (Show)+ deriving (Show) instance Exception Boom @@ -37,53 +37,53 @@ checkProgramMonad :: Spec checkProgramMonad = do- describe "Context type" $ do- it "Eq instance for None behaves" $ do- None `shouldBe` None+ describe "Context type" $ do+ it "Eq instance for None behaves" $ do+ None `shouldBe` None - describe "Program monad" $ do- it "execute with blank Context as expected" $ do- context <- configure "0.1" None blank- executeWith context $ do- user <- getApplicationState- liftIO $ do- user `shouldBe` None+ describe "Program monad" $ do+ it "execute with blank Context as expected" $ do+ context <- configure "0.1" None blankConfig+ executeWith context $ do+ user <- getApplicationState+ liftIO $ do+ user `shouldBe` None - it "execute with simple Context as expected" $ do- context <- configure "0.1" None (simple options)- executeWith context $ do- params <- getCommandLine- liftIO $ do- -- this assumes that hspec isn't passing any- -- command-line arguments through to us.- params `shouldBe` (Parameters Nothing emptyMap emptyMap)+ it "execute with simple Context as expected" $ do+ context <- configure "0.1" None (simpleConfig options)+ executeWith context $ do+ params <- getCommandLine+ liftIO $ do+ -- this assumes that hspec isn't passing any+ -- command-line arguments through to us.+ params `shouldBe` (Parameters Nothing emptyMap emptyMap) - -- not strictly necessary but sets up next spec item- it "sub-programs can be run" $ do- context <- configure "0.1" None blank- user <- subProgram context (getApplicationState)- user `shouldBe` None+ -- not strictly necessary but sets up next spec item+ it "sub-programs can be run" $ do+ context <- configure "0.1" None blankConfig+ user <- subProgram context (getApplicationState)+ user `shouldBe` None - it "unlifting from lifted IO works" $ do- execute $ do- user1 <- getApplicationState- withContext $ \runProgram -> do- user1 `shouldBe` None- user2 <- runProgram getApplicationState -- unlift!- user2 `shouldBe` user1+ it "unlifting from lifted IO works" $ do+ execute $ do+ user1 <- getApplicationState+ withContext $ \runProgram -> do+ user1 `shouldBe` None+ user2 <- runProgram getApplicationState -- unlift!+ user2 `shouldBe` user1 - it "thrown Exceptions can be caught" $ do- context <- configure "0.1" None blank- (subProgram context (throw Boom)) `shouldThrow` boom+ it "thrown Exceptions can be caught" $ do+ context <- configure "0.1" None blankConfig+ (subProgram context (throw Boom)) `shouldThrow` boom - -- ok, so with that established, now try **safe-exceptions**'s- -- code. Note if we move the exception handling code from- -- `execute` to `subProgram` this will have to adapt.- Safe.catch- (subProgram context (throw Boom))- (\(_ :: Boom) -> return ())+ -- ok, so with that established, now try **safe-exceptions**'s+ -- code. Note if we move the exception handling code from+ -- `execute` to `subProgram` this will have to adapt.+ Safe.catch+ (subProgram context (throw Boom))+ (\(_ :: Boom) -> return ()) - it "MonadThrow and MonadCatch behave" $ do- context <- configure "0.1" None blank- subProgram context $ do- Safe.catch (Safe.throw Boom) (\(_ :: Boom) -> return ())+ it "MonadThrow and MonadCatch behave" $ do+ context <- configure "0.1" None blankConfig+ subProgram context $ do+ Safe.catch (Safe.throw Boom) (\(_ :: Boom) -> return ())
tests/CheckRopeBehaviour.hs view
@@ -2,11 +2,10 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module CheckRopeBehaviour- ( checkRopeBehaviour,+module CheckRopeBehaviour (+ checkRopeBehaviour, main,- )-where+) where import Core.System (finally) import Core.Text.Rope@@ -23,7 +22,7 @@ main :: IO () main = do- finally (hspec checkRopeBehaviour) (putStrLn ".")+ finally (hspec checkRopeBehaviour) (putStrLn ".") hydrogen = "H₂" :: Rope @@ -35,217 +34,236 @@ checkRopeBehaviour :: Spec checkRopeBehaviour = do- describe "Rope data type" $ do- it "knows what a singleton is" $ do- singletonRope 'i' `shouldBe` "i"+ describe "Rope data type" $ do+ it "knows what a singleton is" $ do+ singletonRope 'i' `shouldBe` "i" - it "IsString instance behaves" $ do- unRope ("Hello" :: Rope) `shouldBe` F.singleton (S.pack "Hello")+ it "IsString instance behaves" $ do+ unRope ("Hello" :: Rope) `shouldBe` F.singleton (S.pack "Hello") - it "calculates length accurately" $ do- widthRope hydrogen `shouldBe` 2- widthRope sulfate `shouldBe` 3- widthRope (hydrogen <> sulfate) `shouldBe` 5+ it "calculates length accurately" $ do+ widthRope hydrogen `shouldBe` 2+ widthRope sulfate `shouldBe` 3+ widthRope (hydrogen <> sulfate) `shouldBe` 5 - it "Eq instance behaves" $ do- ("" :: Rope) == ("" :: Rope) `shouldBe` True- ("C" :: Rope) /= ("" :: Rope) `shouldBe` True- ("" :: Rope) /= ("F" :: Rope) `shouldBe` True- ("O" :: Rope) == ("O" :: Rope) `shouldBe` True- ("H₂" :: Rope) == ("H₂" :: Rope) `shouldBe` True- ("H₂" :: Rope) /= ("SO₄" :: Rope) `shouldBe` True+ it "Eq instance behaves" $ do+ ("" :: Rope) == ("" :: Rope) `shouldBe` True+ ("C" :: Rope) /= ("" :: Rope) `shouldBe` True+ ("" :: Rope) /= ("F" :: Rope) `shouldBe` True+ ("O" :: Rope) == ("O" :: Rope) `shouldBe` True+ ("H₂" :: Rope) == ("H₂" :: Rope) `shouldBe` True+ ("H₂" :: Rope) /= ("SO₄" :: Rope) `shouldBe` True - it "Hashable instance behaves" $ do- hash ("Hello" :: Rope) `shouldBe` hash (singletonRope 'H' <> intoRope ("ello" :: String))+ it "can be copied into a single piece" $ do+ copyRope compound `shouldBe` ("3-ethyl-4-methylhexane" :: Rope) - -- depended on Textual instance for String being fixed and- -- the Eq instance being customized to ignore tree structure- it "concatonates two Ropes correctly (Monoid)" $ do- ("H₂" :: Rope) <> ("SO₄" :: Rope) `shouldBe` ("H₂SO₄" :: Rope)+ it "Hashable instance behaves" $ do+ hash compound `shouldBe` hash ("3-ethyl-4-methylhexane" :: Rope) - it "concatonates two Ropes correctly (Textual)" $ do- appendRope ("SO₄" :: Rope) ("H₂" :: Rope) `shouldBe` ("H₂SO₄" :: Rope)+ -- depended on Textual instance for String being fixed and+ -- the Eq instance being customized to ignore tree structure+ it "concatonates two Ropes correctly (Monoid)" $ do+ ("H₂" :: Rope) <> ("SO₄" :: Rope) `shouldBe` ("H₂SO₄" :: Rope) - it "replicates itself" $ do- replicateRope 3 "hello" `shouldBe` ("hellohellohello" :: Rope)- length (unRope (replicateRope 3 "hello")) `shouldBe` 3- replicateRope 3 "" `shouldBe` emptyRope- replicateRope 0 "hello" `shouldBe` emptyRope- replicateChar 3 'x' `shouldBe` ("xxx" :: Rope)- replicateChar 0 'x' `shouldBe` ("" :: Rope)+ it "concatonates two Ropes correctly (Textual)" $ do+ appendRope ("SO₄" :: Rope) ("H₂" :: Rope) `shouldBe` ("H₂SO₄" :: Rope) - it "exports to ByteString" $- let expected = T.encodeUtf8 (T.pack "H₂SO₄")- in do- fromRope sulfuric_acid `shouldBe` expected+ it "replicates itself" $ do+ replicateRope 3 "hello" `shouldBe` ("hellohellohello" :: Rope)+ length (unRope (replicateRope 3 "hello")) `shouldBe` 3+ replicateRope 3 "" `shouldBe` emptyRope+ replicateRope 0 "hello" `shouldBe` emptyRope+ replicateChar 3 'x' `shouldBe` ("xxx" :: Rope)+ replicateChar 0 'x' `shouldBe` ("" :: Rope) - it "exports to Text (Strict)" $ do- fromRope sulfuric_acid `shouldBe` T.pack "H₂SO₄"+ it "exports to ByteString" $+ let expected = T.encodeUtf8 (T.pack "H₂SO₄")+ in do+ fromRope sulfuric_acid `shouldBe` expected - it "exports to Text (Lazy)" $ do- fromRope sulfuric_acid `shouldBe` U.pack "H₂SO₄"+ it "exports to Text (Strict)" $ do+ fromRope sulfuric_acid `shouldBe` T.pack "H₂SO₄" - it "does the splits" $ do- -- compare behaviour on Haskell lists- List.splitAt 0 ("123456789" :: String) `shouldBe` ("", "123456789")- List.splitAt 3 ("123456789" :: String) `shouldBe` ("123", "456789")+ it "exports to Text (Lazy)" $ do+ fromRope sulfuric_acid `shouldBe` U.pack "H₂SO₄" - -- expect same behaviour of Rope- splitRope 0 ("123456789" :: Rope) `shouldBe` ("", "123456789")- splitRope 3 ("123456789" :: Rope) `shouldBe` ("123", "456789")- splitRope 9 ("123456789" :: Rope) `shouldBe` ("123456789", "")- splitRope 10 ("123456789" :: Rope) `shouldBe` ("123456789", "")- splitRope (-1) ("123456789" :: Rope) `shouldBe` ("", "123456789")+ it "knows how to use an Oxford comma properly" $ do+ oxford ["one", "two", "three"] `shouldBe` "one, two, and three"+ oxford ["four", "five"] `shouldBe` "four and five"+ oxford ["six"]`shouldBe`"six"+ oxford []`shouldBe`"" - -- exercise splitRopeting at and between piece boundaries- splitRope 0 compound `shouldBe` ("", "3-ethyl-4-methylhexane")- splitRope 1 compound `shouldBe` ("3", "-ethyl-4-methylhexane")- splitRope 2 compound `shouldBe` ("3-", "ethyl-4-methylhexane")- splitRope 4 compound `shouldBe` ("3-et", "hyl-4-methylhexane")- -- 1234567890- splitRope 10 compound `shouldBe` ("3-ethyl-4-", "methylhexane")- splitRope 11 compound `shouldBe` ("3-ethyl-4-m", "ethylhexane")- splitRope 16 compound `shouldBe` ("3-ethyl-4-methyl", "hexane")- splitRope 21 compound `shouldBe` ("3-ethyl-4-methylhexan", "e")- widthRope compound `shouldBe` 22- splitRope 22 compound `shouldBe` ("3-ethyl-4-methylhexane", "")- splitRope 23 compound `shouldBe` ("3-ethyl-4-methylhexane", "")- splitRope (-1) compound `shouldBe` ("", "3-ethyl-4-methylhexane")+ it "does the splits" $ do+ -- compare behaviour on Haskell lists+ List.splitAt 0 ("123456789" :: String) `shouldBe` ("", "123456789")+ List.splitAt 3 ("123456789" :: String) `shouldBe` ("123", "456789") - it "does insertion correctly" $ do- insertRope 3 "two" "onethree" `shouldBe` "onetwothree"- insertRope 3 "Con" "Def 1" `shouldBe` "DefCon 1"- insertRope 0 "one" "twothree" `shouldBe` "onetwothree"- insertRope 6 "three" "onetwo" `shouldBe` "onetwothree"+ -- expect same behaviour of Rope+ splitRope 0 ("123456789" :: Rope) `shouldBe` ("", "123456789")+ splitRope 3 ("123456789" :: Rope) `shouldBe` ("123", "456789")+ splitRope 9 ("123456789" :: Rope) `shouldBe` ("123456789", "")+ splitRope 10 ("123456789" :: Rope) `shouldBe` ("123456789", "")+ splitRope (-1) ("123456789" :: Rope) `shouldBe` ("", "123456789") - it "finds characters correctly" $ do- findIndexRope (== '3') compound `shouldBe` (Just 0)- findIndexRope (== '4') compound `shouldBe` (Just 8)- findIndexRope (== '!') compound `shouldBe` Nothing- findIndexRope (== 'e') compound `shouldBe` (Just 2)+ -- exercise splitRopeting at and between piece boundaries+ splitRope 0 compound `shouldBe` ("", "3-ethyl-4-methylhexane")+ splitRope 1 compound `shouldBe` ("3", "-ethyl-4-methylhexane")+ splitRope 2 compound `shouldBe` ("3-", "ethyl-4-methylhexane")+ splitRope 4 compound `shouldBe` ("3-et", "hyl-4-methylhexane")+ -- 1234567890+ splitRope 10 compound `shouldBe` ("3-ethyl-4-", "methylhexane")+ splitRope 11 compound `shouldBe` ("3-ethyl-4-m", "ethylhexane")+ splitRope 16 compound `shouldBe` ("3-ethyl-4-methyl", "hexane")+ splitRope 21 compound `shouldBe` ("3-ethyl-4-methylhexan", "e")+ widthRope compound `shouldBe` 22+ splitRope 22 compound `shouldBe` ("3-ethyl-4-methylhexane", "")+ splitRope 23 compound `shouldBe` ("3-ethyl-4-methylhexane", "")+ splitRope (-1) compound `shouldBe` ("", "3-ethyl-4-methylhexane") - describe "QuasiQuoted string literals" $ do- it "string literal is IsString" $ do- [quote|Hello|] `shouldBe` ("Hello" :: String)- [quote|Hello|] `shouldBe` ("Hello" :: Rope)+ it "takes from beginning" $ do+ List.take 0 ("123456789" :: String) `shouldBe` ""+ List.take 3 ("123456789" :: String) `shouldBe` "123"+ List.take 10 ("123456789" :: String) `shouldBe` "123456789" - it "trims multi-line string literal" $ do- [quote|+ -- expect same behaviour of Rope+ takeRope 0 ("123456789" :: Rope) `shouldBe` ""+ takeRope 3 ("123456789" :: Rope) `shouldBe` "123"+ takeRope 10 ("123456789" :: Rope) `shouldBe` "123456789"++ it "does insertion correctly" $ do+ insertRope 3 "two" "onethree" `shouldBe` "onetwothree"+ insertRope 3 "Con" "Def 1" `shouldBe` "DefCon 1"+ insertRope 0 "one" "twothree" `shouldBe` "onetwothree"+ insertRope 6 "three" "onetwo" `shouldBe` "onetwothree"++ it "finds characters correctly" $ do+ findIndexRope (== '3') compound `shouldBe` (Just 0)+ findIndexRope (== '4') compound `shouldBe` (Just 8)+ findIndexRope (== '!') compound `shouldBe` Nothing+ findIndexRope (== 'e') compound `shouldBe` (Just 2)++ describe "QuasiQuoted string literals" $ do+ it "string literal is IsString" $ do+ [quote|Hello|] `shouldBe` ("Hello" :: String)+ [quote|Hello|] `shouldBe` ("Hello" :: Rope)++ it "trims multi-line string literal" $ do+ [quote| Hello |]- `shouldBe` ("Hello\n" :: Rope)- [quote|+ `shouldBe` ("Hello\n" :: Rope)+ [quote| Hello World |]- `shouldBe` ("Hello\nWorld\n" :: Rope)+ `shouldBe` ("Hello\nWorld\n" :: Rope) - describe "Splitting into words" $ do- it "breaks short text into chunks" $ do- intoChunks isSpace "" `shouldBe` []- intoChunks isSpace "Hello" `shouldBe` ["Hello"]- intoChunks isSpace "Hello World" `shouldBe` ["Hello", "World"]- intoChunks isSpace "Hello " `shouldBe` ["Hello", ""]- intoChunks isSpace " Hello" `shouldBe` ["", "Hello"]- intoChunks isSpace " Hello " `shouldBe` ["", "Hello", ""]+ describe "Splitting into words" $ do+ it "breaks short text into chunks" $ do+ intoChunks isSpace "" `shouldBe` []+ intoChunks isSpace "Hello" `shouldBe` ["Hello"]+ intoChunks isSpace "Hello World" `shouldBe` ["Hello", "World"]+ intoChunks isSpace "Hello " `shouldBe` ["Hello", ""]+ intoChunks isSpace " Hello" `shouldBe` ["", "Hello"]+ intoChunks isSpace " Hello " `shouldBe` ["", "Hello", ""] - it "breaks consecutive short texts into chunks" $ do- intoPieces isSpace "Hello" (Nothing, [])- `shouldBe` (Just "Hello", [])- intoPieces isSpace "" (Nothing, [])- `shouldBe` (Nothing, [])- intoPieces isSpace "" (Nothing, ["World"])- `shouldBe` (Nothing, ["World"])- intoPieces isSpace "This is" (Nothing, ["", "a", "", "test."])- `shouldBe` (Just "This", ["is", "", "a", "", "test."])- intoPieces isSpace "This i" (Just "s", ["", "a", "", "test."])- `shouldBe` (Just "This", ["is", "", "a", "", "test."])+ it "breaks consecutive short texts into chunks" $ do+ intoPieces isSpace "Hello" (Nothing, [])+ `shouldBe` (Just "Hello", [])+ intoPieces isSpace "" (Nothing, [])+ `shouldBe` (Nothing, [])+ intoPieces isSpace "" (Nothing, ["World"])+ `shouldBe` (Nothing, ["World"])+ intoPieces isSpace "This is" (Nothing, ["", "a", "", "test."])+ `shouldBe` (Just "This", ["is", "", "a", "", "test."])+ intoPieces isSpace "This i" (Just "s", ["", "a", "", "test."])+ `shouldBe` (Just "This", ["is", "", "a", "", "test."]) - it "single piece containing multiple words splits correctly" $- let text = "This is a test"- in do- breakWords text `shouldBe` ["This", "is", "a", "test"]+ it "single piece containing multiple words splits correctly" $+ let text = "This is a test"+ in do+ breakWords text `shouldBe` ["This", "is", "a", "test"] - it "single piece, long run of whitespace splits correctly" $- let text = "This is\na test"- in do- breakWords text `shouldBe` ["This", "is", "a", "test"]+ it "single piece, long run of whitespace splits correctly" $+ let text = "This is\na test"+ in do+ breakWords text `shouldBe` ["This", "is", "a", "test"] - it "text spanning two pieces can be split into words" $- let text = "This is " <> "a test"- in do- breakWords text `shouldBe` ["This", "is", "a", "test"]+ it "text spanning two pieces can be split into words" $+ let text = "This is " <> "a test"+ in do+ breakWords text `shouldBe` ["This", "is", "a", "test"] - it "text spanning many pieces can be split into words" $- let text = "st" <> "" <> "op" <> "" <> " " <> " " <> "and go" <> "op"- in do- breakWords text `shouldBe` ["stop", "and", "goop"]+ it "text spanning many pieces can be split into words" $+ let text = "st" <> "" <> "op" <> "" <> " " <> " " <> "and go" <> "op"+ in do+ breakWords text `shouldBe` ["stop", "and", "goop"] - it "empty and whitespace-only corner cases handled correctly" $- let text = " " <> "" <> "stop" <> "" <> " "- in do- breakWords text `shouldBe` ["stop"]+ it "empty and whitespace-only corner cases handled correctly" $+ let text = " " <> "" <> "stop" <> "" <> " "+ in do+ breakWords text `shouldBe` ["stop"] - describe "Splitting into lines" $ do- it "preconditions are met" $ do- breakLines "" `shouldBe` []- breakLines "Hello" `shouldBe` ["Hello"]- breakLines "Hello\nWorld" `shouldBe` ["Hello", "World"]- breakLines "Hello\n" `shouldBe` ["Hello"]- breakLines "\nHello" `shouldBe` ["", "Hello"]- breakLines "\nHello\n" `shouldBe` ["", "Hello"]- breakLines "Hello\nWorld\n" `shouldBe` ["Hello", "World"]- breakLines "Hello\n\nWorld\n" `shouldBe` ["Hello", "", "World"]- breakLines "Hello\n\nWorld\n\n" `shouldBe` ["Hello", "", "World", ""]+ describe "Splitting into lines" $ do+ it "preconditions are met" $ do+ breakLines "" `shouldBe` []+ breakLines "Hello" `shouldBe` ["Hello"]+ breakLines "Hello\nWorld" `shouldBe` ["Hello", "World"]+ breakLines "Hello\n" `shouldBe` ["Hello"]+ breakLines "\nHello" `shouldBe` ["", "Hello"]+ breakLines "\nHello\n" `shouldBe` ["", "Hello"]+ breakLines "Hello\nWorld\n" `shouldBe` ["Hello", "World"]+ breakLines "Hello\n\nWorld\n" `shouldBe` ["Hello", "", "World"]+ breakLines "Hello\n\nWorld\n\n" `shouldBe` ["Hello", "", "World", ""] - it "single piece containing multiple lines splits correctly" $- let para =- [quote|+ it "single piece containing multiple lines splits correctly" $+ let para =+ [quote| This is a test of the Emergency Broadcast System, beeeeep |]- in do- breakLines para- `shouldBe` [ "This is a test",- "of the Emergency",- "Broadcast",- "System, beeeeep"- ]+ in do+ breakLines para+ `shouldBe` [ "This is a test"+ , "of the Emergency"+ , "Broadcast"+ , "System, beeeeep"+ ] - it "preserves blank lines" $- let para =- [quote|+ it "preserves blank lines" $+ let para =+ [quote| First line. Third line. |]- in do- breakLines para- `shouldBe` [ "First line.",- "",- "Third line."- ]+ in do+ breakLines para+ `shouldBe` [ "First line."+ , ""+ , "Third line."+ ] - describe "Formatting paragraphs" $ do- it "multi-line paragraph rewraps correctly" $- let para =- [quote|+ describe "Formatting paragraphs" $ do+ it "multi-line paragraph rewraps correctly" $+ let para =+ [quote| Hello this is a test of the Emergency Broadcast System |]- in wrap 20 para- `shouldBe` [quote|+ in wrap 20 para+ `shouldBe` [quote| Hello this is a test of the Emergency Broadcast System|] - describe "Lines and columns" $ do- it "calculate position of a given block" $ do- calculatePositionEnd "" `shouldBe` (1, 1)- calculatePositionEnd "Hello" `shouldBe` (1, 6)- calculatePositionEnd "Hello\nWorld" `shouldBe` (2, 6)- calculatePositionEnd "\nWorld" `shouldBe` (2, 6)- calculatePositionEnd "\n" `shouldBe` (2, 1)+ describe "Lines and columns" $ do+ it "calculate position of a given block" $ do+ calculatePositionEnd "" `shouldBe` (1, 1)+ calculatePositionEnd "Hello" `shouldBe` (1, 6)+ calculatePositionEnd "Hello\nWorld" `shouldBe` (2, 6)+ calculatePositionEnd "\nWorld" `shouldBe` (2, 6)+ calculatePositionEnd "\n" `shouldBe` (2, 1)
+ tests/CheckTelemetryMachinery.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module CheckTelemetryMachinery where++import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TQueue (newTQueueIO, writeTQueue)+import Core.Program.Execute (loopForever)+import Core.System+import qualified Control.Concurrent.Async as Async (async, wait)++import Test.Hspec hiding (context)+import Control.Concurrent (threadDelay)++countingAction :: Int -> [Int] -> IO ()+countingAction target ints = sum ints `shouldBe` target++matchingAction :: [Int] -> [Int] -> IO ()+matchingAction target items = items `shouldBe` target++store :: MVar [Int]+store = unsafePerformIO (newMVar [])++storingAction :: [Int] -> IO ()+storingAction items = do+ modifyMVar_ store (\value -> pure (value ++ items))++checkTelemetryMachinery :: Spec+checkTelemetryMachinery = do+ describe "Queue processing" $ do+ it "processes an item put on queue" $ do+ out <- newTQueueIO+ queue <- newTQueueIO++ atomically $ do+ writeTQueue queue (Just 1)+ writeTQueue queue Nothing++ loopForever (countingAction 1) out queue++ it "processes mutlitple items" $ do+ out <- newTQueueIO+ queue <- newTQueueIO++ atomically $ do+ writeTQueue queue (Just 1)+ writeTQueue queue (Just 2)+ writeTQueue queue (Just 3)+ writeTQueue queue Nothing++ loopForever (matchingAction [1, 2, 3]) out queue++ it "stops even if only empty" $ do+ out <- newTQueueIO+ queue <- newTQueueIO++ atomically $ do+ writeTQueue queue Nothing++ loopForever (countingAction 0) out queue++ it "extended sequeence handled in right order" $ do+ out <- newTQueueIO+ queue <- newTQueueIO++ a <- Async.async (loopForever storingAction out queue)++ mapM_+ ( \i -> atomically $ do+ writeTQueue queue (Just i)+ )+ ([1 .. 100] :: [Int])+ threadDelay 100000+ mapM_+ ( \i -> atomically $ do+ writeTQueue queue (Just i)+ )+ ([101 .. 200] :: [Int])+ threadDelay 100000+ mapM_+ ( \i -> atomically $ do+ writeTQueue queue (Just i)+ )+ ([201 .. 300] :: [Int])+++ atomically $ do+ writeTQueue queue Nothing++ Async.wait a++ value <- readMVar store+ value `shouldBe` ([1 .. 300] :: [Int])
− tests/Everything.hs
@@ -1,26 +0,0 @@-{-# OPTIONS_HADDOCK not-home, hide #-}------- This module is not exposed. Should it be? At first seems like a nice--- idea, but caused more problems than anything; you try to actually use--- e.g. Rope and you get a "hidden package core-text" errors.------- |--- Meta package re-exporting all the modules in the collection, which is only--- here so the top level __unbeliever__ package shows dependencies on--- __core-text__, __core-data__, and __core-program__.-module Everything- ( module Core.Text,- module Core.Program,- module Core.Data,- module Core.Encoding,- module Core.System,- )-where--import Core.Data-import Core.Encoding-import Core.Program-import Core.System-import Core.Text
tests/TestSuite.hs view
@@ -6,6 +6,8 @@ import CheckJsonWrapper import CheckProgramMonad import CheckRopeBehaviour (checkRopeBehaviour)+import CheckTelemetryMachinery+ import Core.System import Test.Hspec @@ -21,3 +23,4 @@ checkJsonWrapper checkArgumentsParsing checkProgramMonad+ checkTelemetryMachinery
unbeliever.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: d7965f7477b97450d9b3d2b09522b923db161abba0f2dd52606dfa43c185ccdf name: unbeliever-version: 0.10.0.8+version: 0.11.0.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. Its @Program@ type provides unified ouptut &@@ -34,6 +32,7 @@ * __core-text__ * __core-data__ * __core-program__+ * __core-telemetry__ . with more forthcoming as we continue to add convenince and interoperability wrappers around streaming, webservers, and database@@ -44,29 +43,17 @@ bug-reports: https://github.com/aesiniath/unbeliever/issues author: Andrew Cowie <istathar@gmail.com> maintainer: Andrew Cowie <istathar@gmail.com>-copyright: © 2018-2020 Athae Eredh Siniath and Others-license: BSD3+copyright: © 2018-2021 Athae Eredh Siniath and Others+license: MIT license-file: LICENSE-tested-with: GHC == 8.8.4 build-type: Simple+tested-with:+ GHC == 8.10.7 source-repository head type: git location: https://github.com/aesiniath/unbeliever -library- other-modules:- Everything- hs-source-dirs:- tests- ghc-options: -Wall -Wwarn -fwarn-tabs- build-depends:- base >=4.11 && <5- , core-data >=0.2.1.9- , core-program >=0.2.6.0- , core-text >=0.3.0.0- default-language: Haskell2010- test-suite check type: exitcode-stdio-1.0 main-is: TestSuite.hs@@ -77,20 +64,24 @@ CheckJsonWrapper CheckProgramMonad CheckRopeBehaviour+ CheckTelemetryMachinery hs-source-dirs: tests ghc-options: -Wall -Wwarn -fwarn-tabs -threaded build-depends:- base >=4.11 && <5+ async+ , base >=4.11 && <5 , bytestring- , core-data >=0.2.1.9- , core-program >=0.2.6.0- , core-text >=0.3.0.0+ , core-data >=0.3.0.0+ , core-program >=0.3.0.8+ , core-telemetry >=0.1.6.1+ , core-text >=0.3.4.0 , fingertree , hashable , hspec , prettyprinter , safe-exceptions+ , stm , text , text-short , unordered-containers@@ -105,9 +96,10 @@ build-depends: base >=4.11 && <5 , bytestring- , core-data >=0.2.1.9- , core-program >=0.2.6.0- , core-text >=0.3.0.0+ , core-data >=0.3.0.0+ , core-program >=0.3.0.8+ , core-telemetry >=0.1.6.1+ , core-text >=0.3.4.0 , gauge , text default-language: Haskell2010