diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/tests/CheckArgumentsParsing.hs b/tests/CheckArgumentsParsing.hs --- a/tests/CheckArgumentsParsing.hs +++ b/tests/CheckArgumentsParsing.hs @@ -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 diff --git a/tests/CheckContainerBehaviour.hs b/tests/CheckContainerBehaviour.hs --- a/tests/CheckContainerBehaviour.hs +++ b/tests/CheckContainerBehaviour.hs @@ -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 "&") diff --git a/tests/CheckJsonWrapper.hs b/tests/CheckJsonWrapper.hs --- a/tests/CheckJsonWrapper.hs +++ b/tests/CheckJsonWrapper.hs @@ -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 diff --git a/tests/CheckProgramMonad.hs b/tests/CheckProgramMonad.hs --- a/tests/CheckProgramMonad.hs +++ b/tests/CheckProgramMonad.hs @@ -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 ()) diff --git a/tests/CheckRopeBehaviour.hs b/tests/CheckRopeBehaviour.hs --- a/tests/CheckRopeBehaviour.hs +++ b/tests/CheckRopeBehaviour.hs @@ -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) diff --git a/tests/CheckTelemetryMachinery.hs b/tests/CheckTelemetryMachinery.hs new file mode 100644 --- /dev/null +++ b/tests/CheckTelemetryMachinery.hs @@ -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]) diff --git a/tests/Everything.hs b/tests/Everything.hs deleted file mode 100644 --- a/tests/Everything.hs +++ /dev/null @@ -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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -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 diff --git a/unbeliever.cabal b/unbeliever.cabal --- a/unbeliever.cabal +++ b/unbeliever.cabal @@ -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 maintainer: Andrew Cowie -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