diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,6 +1,6 @@ Opinionated Haskell Interoperability -Copyright © 2018 Operational Dynamics Consulting, Pty Ltd and Others +Copyright © 2018-2019 Operational Dynamics Consulting, Pty Ltd and Others All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs --- a/lib/Core/Program/Execute.hs +++ b/lib/Core/Program/Execute.hs @@ -1,9 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} @@ -272,7 +269,7 @@ -- putting to the quit MVar initiates the cleanup and exit sequence, -- but throwing the exception also aborts execution and starts unwinding -- back up the stack. -terminate :: Int -> Program τ () +terminate :: Int -> Program τ α terminate code = let exit = case code of diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs --- a/lib/Core/Program/Logging.hs +++ b/lib/Core/Program/Logging.hs @@ -160,7 +160,7 @@ let display = case potentialValue of Just value -> - if contains '\n' value + if containsCharacter '\n' value then text <> " =\n" <> value else text <> " = " <> value Nothing -> text diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs --- a/lib/Core/System/Base.hs +++ b/lib/Core/System/Base.hs @@ -21,12 +21,16 @@ {-** from Control.Exception.Safe -} {-| Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: -} , Exception(..) + , SomeException , throw + , impureThrow , bracket , catch + , finally ) where -import Control.Exception.Safe (Exception(..), throw, bracket, catch) +import Control.Exception.Safe (Exception(..), SomeException, throw + , bracket, catch, finally, impureThrow) import Control.Monad.IO.Class (MonadIO, liftIO) import System.IO (Handle, stdin, stdout, stderr, hFlush) import System.IO.Unsafe (unsafePerformIO) diff --git a/lib/Core/Text/Bytes.hs b/lib/Core/Text/Bytes.hs --- a/lib/Core/Text/Bytes.hs +++ b/lib/Core/Text/Bytes.hs @@ -74,6 +74,10 @@ fromBytes :: Bytes -> α intoBytes :: α -> Bytes +instance Binary Bytes where + fromBytes = id + intoBytes = id + {-| from "Data.ByteString" Strict -} instance Binary B.ByteString where fromBytes (StrictBytes b') = b' diff --git a/lib/Core/Text/Rope.hs b/lib/Core/Text/Rope.hs --- a/lib/Core/Text/Rope.hs +++ b/lib/Core/Text/Rope.hs @@ -74,12 +74,13 @@ module Core.Text.Rope ( {-* Rope type -} Rope - , width - , split - , insert - , contains + , emptyRope + , widthRope + , splitRope + , insertRope + , containsCharacter {-* Interoperation and Output -} - , Textual(fromRope, intoRope, append) + , Textual(fromRope, intoRope, appendRope) , hWrite {-* Internals -} , unRope @@ -93,10 +94,11 @@ , hPutBuilder) import qualified Data.ByteString.Lazy as L (ByteString, toStrict , foldrChunks) -import Data.String (IsString(..)) import qualified Data.FingerTree as F (FingerTree, Measured(..), empty - , singleton, (><), (<|), (|>), search, SearchResult(..)) + , singleton, (><), (<|), (|>), search, SearchResult(..), null) import Data.Foldable (foldr, foldr', foldMap, toList, any) +import Data.Hashable (Hashable, hashWithSalt) +import Data.String (IsString(..)) import qualified Data.Text as T (Text) import qualified Data.Text.Lazy as U (Text, fromChunks, foldrChunks , toStrict) @@ -107,7 +109,6 @@ , fromText, toText, fromByteString, pack, unpack , append, empty, toBuilder, splitAt) import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe) -import Data.Hashable (Hashable, hashWithSalt) import GHC.Generics (Generic) import System.IO (Handle) @@ -141,8 +142,8 @@ This involves considerable appending of data, very very occaisionally inserting it. Often the pieces are tiny. To add text to a @Rope@ use the -'append' method as below or ('Data.Semigroup.<>') from "Data.Monoid" (like you -would have with a @Builder@). +'appendRope' method as below or the ('Data.Semigroup.<>') operator from +"Data.Monoid" (like you would have with a @Builder@). Output to a @Handle@ can be done efficiently with 'hWrite'. -} @@ -203,20 +204,35 @@ -- FingerTree Strand or Builder (Strand) instance IsString Rope where - fromString = Rope . F.singleton . S.pack + fromString "" = emptyRope + fromString xs = Rope . F.singleton . S.pack $ xs instance Semigroup Rope where - (<>) (Rope x1) (Rope x2) = Rope ((F.><) x1 x2) -- god I hate these operators + (<>) text1@(Rope x1) text2@(Rope x2) = + if F.null x2 + then text1 + else if F.null x1 + then text2 + else Rope ((F.><) x1 x2) -- god I hate these operators instance Monoid Rope where - mempty = Rope F.empty + mempty = emptyRope mappend = (<>) {-| +An zero-length 'Rope'. You can also use @\"\"@ presuming the +__@OverloadedStrings@__ language extension is turned on in your source +file. +-} +emptyRope :: Rope +emptyRope = Rope F.empty +{-# INLINABLE emptyRope #-} + +{-| Get the length of this text, in characters. -} -width :: Rope -> Int -width = foldr' f 0 . unRope +widthRope :: Rope -> Int +widthRope = foldr' f 0 . unRope where f piece count = S.length piece + count @@ -226,25 +242,25 @@ Examples: @ -λ> __split 0 \"abcdef\"__ +λ> __splitRope 0 \"abcdef\"__ (\"\", \"abcdef\") -λ> __split 3 \"abcdef\"__ +λ> __splitRope 3 \"abcdef\"__ (\"abc\", \"def\") -λ> __split 6 \"abcdef\"__ +λ> __splitRope 6 \"abcdef\"__ (\"abcdef\",\"\") @ Going off either end behaves sensibly: @ -λ> __split 7 \"abcdef\"__ +λ> __splitRope 7 \"abcdef\"__ (\"abcdef\",\"\") -λ> __split (-1) \"abcdef\"__ +λ> __splitRope (-1) \"abcdef\"__ (\"\", \"abcdef\") @ -} -split :: Int -> Rope -> (Rope,Rope) -split i text@(Rope x) = +splitRope :: Int -> Rope -> (Rope,Rope) +splitRope i text@(Rope x) = let pos = Width i result = F.search (\w1 _ -> w1 >= pos) x @@ -266,21 +282,20 @@ Examples: @ -λ> __insert 3 \"Con\" \"Def 1\"__ +λ> __insertRope 3 \"Con\" \"Def 1\"__ "DefCon 1" -λ> __insert 0 \"United \" \"Nations\"__ +λ> __insertRope 0 \"United \" \"Nations\"__ "United Nations" @ -} -insert :: Int -> Rope -> Rope -> Rope -insert 0 (Rope new) (Rope x) = Rope ((F.><) new x) -insert i (Rope new) text = +insertRope :: Int -> Rope -> Rope -> Rope +insertRope 0 (Rope new) (Rope x) = Rope ((F.><) new x) +insertRope i (Rope new) text = let - (Rope before,Rope after) = split i text + (Rope before,Rope after) = splitRope i text in Rope (mconcat [before, new, after]) - -- -- Manual instance to get around the fact that FingerTree doesn't have a -- Hashable instance. If this were ever to become a hotspot we could @@ -311,11 +326,11 @@ collector manage the memory, so instances are expected to /copy/ these substrings out of pinned memory. -The @ByteString@ instance requires that its content be valid UTF-8. If not an -empty @Rope@ will be returned. +The @ByteString@ instance requires that its content be valid UTF-8. If not +an empty @Rope@ will be returned. Several of the 'fromRope' implementations are expensive and involve a lot -of intermiate allocation and copying. If you're ultimately writing to a +of intermediate allocation and copying. If you're ultimately writing to a handle prefer 'hWrite' which will write directly to the output buffer. -} class Textual α where @@ -333,8 +348,8 @@ text (which will work just fine, but for some types more efficient implementations are possible). -} - append :: α -> Rope -> Rope - append thing text = text <> intoRope thing + appendRope :: α -> Rope -> Rope + appendRope thing text = text <> intoRope thing instance Textual (F.FingerTree Width S.ShortText) where fromRope = unRope @@ -343,13 +358,13 @@ instance Textual Rope where fromRope = id intoRope = id - append (Rope x2) (Rope x1) = Rope ((F.><) x1 x2) + appendRope (Rope x2) (Rope x1) = Rope ((F.><) x1 x2) {-| from "Data.Text.Short" -} instance Textual S.ShortText where fromRope = foldr S.append S.empty . unRope intoRope = Rope . F.singleton - append piece (Rope x) = Rope ((F.|>) x piece) + appendRope piece (Rope x) = Rope ((F.|>) x piece) {-| from "Data.Text" Strict -} instance Textual T.Text where @@ -359,7 +374,7 @@ f piece built = (<>) (U.fromText (S.toText piece)) built intoRope t = Rope (F.singleton (S.fromText t)) - append chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk)) + appendRope chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk)) {-| from "Data.Text.Lazy" -} instance Textual U.Text where @@ -379,7 +394,7 @@ Nothing -> Rope F.empty -- bad -- ditto - append b' (Rope x) = case S.fromByteString b' of + appendRope b' (Rope x) = case S.fromByteString b' of Just piece -> Rope ((F.|>) x piece) Nothing -> (Rope x) -- bad @@ -449,12 +464,12 @@ example: @ - if 'contains' '\n' text + if 'containsCharacter' \'\n\' text then handleComplexCase else keepItSimple @ -} -contains :: Char -> Rope -> Bool -contains q (Rope x) = any j x +containsCharacter :: Char -> Rope -> Bool +containsCharacter q (Rope x) = any j x where j piece = S.any (\c -> c == q) piece diff --git a/lib/Core/Text/Utilities.hs b/lib/Core/Text/Utilities.hs --- a/lib/Core/Text/Utilities.hs +++ b/lib/Core/Text/Utilities.hs @@ -16,18 +16,22 @@ , render {-* Helpers -} , indefinite + , breakWords + , breakLines + , breakPieces , wrap , underline {-* Multi-line strings -} , quote ) where -import qualified Data.FingerTree as F ((<|), ViewL(..), viewl) +import Data.Char (isSpace) +import qualified Data.FingerTree as F ((<|), ViewL(..), viewl, singleton) import qualified Data.List as List (foldl', dropWhileEnd) import Data.Monoid ((<>)) import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as T -import qualified Data.Text.Short as S (ShortText, uncons, toText) +import qualified Data.Text.Short as S (ShortText, uncons, toText, empty + , null, breakEnd, append, dropEnd) import Data.Text.Prettyprint.Doc (Doc, layoutPretty , reAnnotateS , pretty, emptyDoc , LayoutOptions(LayoutOptions) @@ -73,11 +77,16 @@ f :: S.ShortText -> Doc () -> Doc () f piece built = (<>) (pretty (S.toText piece)) built -instance Render [Char] where - type Token [Char] = () +instance Render Char where + type Token Char = () colourize = const mempty - intoDocA cs = pretty cs + intoDocA c = pretty c +instance (Render a) => Render [a] where + type Token [a] = Token a + colourize = const mempty + intoDocA = mconcat . fmap intoDocA + instance Render T.Text where type Token T.Text = () colourize = const mempty @@ -134,33 +143,143 @@ else intoRope ("a " F.<| x) {-| +Split a passage of text into a list of words. A line is broken wherever +there is one or more whitespace characters, as defined by "Data.Char"'s +'Data.Char.isSpace'. + +Examples: + +@ +λ> __breakWords \"This is a test\"__ +[\"This\",\"is\",\"a\",\"test\"] +λ> __breakWords (\"St\" <> \"op and \" <> \"go left\")__ +[\"Stop\",\"and\",\"go\",\"left\"] +λ> __breakWords emptyRope__ +[] +@ +-} +breakWords :: Rope -> [Rope] +breakWords text = breakPieces isSpace text + +{-| +Split a paragraph of text into a list of its individual lines. The +paragraph will be broken wherever there is a @'\n'@ character. +-} +breakLines :: Rope -> [Rope] +breakLines text = breakPieces isNewline text + +isNewline :: Char -> Bool +isNewline c = c == '\n' + +{-| +Break a Rope into pieces whereever the given predicate function returns +@True@. If found, that character will not be included on either side. +-} +breakPieces :: (Char -> Bool) -> Rope -> [Rope] +breakPieces predicate text = + let + (final,list) = foldr (finder predicate) (S.empty,[]) (unRope text) + l = intoRope (F.singleton final) + in + if S.null final + then list + else l:list + +finder + :: (Char -> Bool) + -> S.ShortText + -> (S.ShortText,[Rope]) + -> (S.ShortText,[Rope]) +finder predicate piece (accum,list) = + let + done = S.null piece + + -- λ> S.breakEnd isSpace "a d" + -- ("a","d") + -- + -- λ> S.breakEnd isSpace " and" + -- (" ","and") + -- + -- λ> S.breakEnd isSpace "and " + -- ("and ","") + -- + -- λ> S.breakEnd isSpace "" + -- ("","") + -- + -- λ> S.breakEnd isSpace " " + -- (" ","") + + (remainder,fragment) = S.breakEnd predicate piece + + -- Are we in the middle of a word? We are if the carry forward is + -- non-zero length. + -- + -- Did we find a word in the current piece? If so, then if we are in + -- the middle of accumulating a word, we add the new piece to it. + + found = not (S.null fragment) + middle = not (S.null accum) + + accum' = if found + then if middle + then S.append fragment accum + else fragment + else accum + + -- Did we find a space? We did if remainder is non-zero length. + -- Finding a space means flushing out the accumulator (though only if + -- there's actually something there). We have to drop that whitespace + -- before iterating. + + space = not (S.null remainder) + empty = S.null accum' + word = intoRope accum' + + list' = if empty + then list + else word:list + + remainder' = S.dropEnd 1 remainder + in + if done + then (accum',list) + else if space + then finder predicate remainder' (S.empty,list') + else finder predicate remainder (accum',list) + +{-| Often the input text represents a paragraph, but does not have any internal newlines (representing word wrapping). This function takes a line of text -and inserts newlines to simulate such folding. It also appends a trailing -newline to finish the paragraph. +and inserts newlines to simulate such folding, keeping the line under +the supplied maximum width. + +A single word that is excessively long will be included as-is on its own +line (that line will exceed the desired maxium width). + +Any trailing newlines will be removed. -} wrap :: Int -> Rope -> Rope wrap margin text = let - built = wrapHelper margin (T.words (fromRope text)) + built = wrapHelper margin (breakWords text) in - intoRope (T.toLazyText built) + built -wrapHelper :: Int -> [T.Text] -> T.Builder +wrapHelper :: Int -> [Rope] -> Rope wrapHelper _ [] = "" -wrapHelper _ [x] = T.fromText x +wrapHelper _ [x] = x wrapHelper margin (x:xs) = - snd $ List.foldl' (wrapLine margin) (T.length x, T.fromText x) xs + snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs -wrapLine :: Int -> (Int, T.Builder) -> T.Text -> (Int, T.Builder) +wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope) wrapLine margin (pos,builder) word = let - wide = T.length word + wide = widthRope word wide' = pos + wide + 1 in if wide' > margin - then (wide , builder <> "\n" <> T.fromText word) - else (wide', builder <> " " <> T.fromText word) + then (wide , builder <> "\n" <> word) + else (wide', builder <> " " <> word) underline :: Char -> Rope -> Rope diff --git a/tests/CheckRopeBehaviour.hs b/tests/CheckRopeBehaviour.hs --- a/tests/CheckRopeBehaviour.hs +++ b/tests/CheckRopeBehaviour.hs @@ -30,9 +30,9 @@ unRope ("Hello" :: Rope) `shouldBe` F.singleton (S.pack "Hello") it "calculates length accurately" $ do - width hydrogen `shouldBe` 2 - width sulfate `shouldBe` 3 - width (hydrogen <> sulfate) `shouldBe` 5 + widthRope hydrogen `shouldBe` 2 + widthRope sulfate `shouldBe` 3 + widthRope (hydrogen <> sulfate) `shouldBe` 5 it "Eq instance behaves" $ do ("" :: Rope) == ("" :: Rope) `shouldBe` True @@ -48,7 +48,7 @@ ("H₂" :: Rope) <> ("SO₄" :: Rope) `shouldBe` ("H₂SO₄" :: Rope) it "concatonates two Ropes correctly (Textual)" $ do - append ("SO₄" :: Rope) ("H₂" :: Rope) `shouldBe` ("H₂SO₄" :: Rope) + appendRope ("SO₄" :: Rope) ("H₂" :: Rope) `shouldBe` ("H₂SO₄" :: Rope) it "exports to ByteString" $ let @@ -68,32 +68,32 @@ List.splitAt 3 ("123456789" :: String) `shouldBe` ("123", "456789") -- expect same behaviour of Rope - split 0 ("123456789" :: Rope) `shouldBe` ("", "123456789") - split 3 ("123456789" :: Rope) `shouldBe` ("123", "456789") - split 9 ("123456789" :: Rope) `shouldBe` ("123456789","") - split 10 ("123456789" :: Rope) `shouldBe` ("123456789","") - split (-1) ("123456789" :: Rope) `shouldBe` ("", "123456789") + 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") - -- exercise splitting at and between piece boundaries - split 0 compound `shouldBe` ("", "3-ethyl-4-methylhexane") - split 1 compound `shouldBe` ("3", "-ethyl-4-methylhexane") - split 2 compound `shouldBe` ("3-", "ethyl-4-methylhexane") - split 4 compound `shouldBe` ("3-et", "hyl-4-methylhexane") + -- 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 - split 10 compound `shouldBe` ("3-ethyl-4-", "methylhexane") - split 11 compound `shouldBe` ("3-ethyl-4-m", "ethylhexane") - split 16 compound `shouldBe` ("3-ethyl-4-methyl", "hexane") - split 21 compound `shouldBe` ("3-ethyl-4-methylhexan", "e") - width compound `shouldBe` 22 - split 22 compound `shouldBe` ("3-ethyl-4-methylhexane", "") - split 23 compound `shouldBe` ("3-ethyl-4-methylhexane", "") - split (-1) compound `shouldBe` ("", "3-ethyl-4-methylhexane") + 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 insertion correctly" $ do - insert 3 "two" "onethree" `shouldBe` "onetwothree" - insert 3 "Con" "Def 1" `shouldBe` "DefCon 1" - insert 0 "one" "twothree" `shouldBe` "onetwothree" - insert 6 "three" "onetwo" `shouldBe` "onetwothree" + 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" describe "QuasiQuoted string literals" $ do @@ -110,3 +110,64 @@ World |] `shouldBe` ("Hello\nWorld\n" :: Rope) + describe "Splitting into words" $ do + 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 "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 "empty and whitespace-only corner cases handled correctly " $ + let + text = " " <> "" <> "stop" <> "" <> " " + in do + breakWords text `shouldBe` ["stop"] + + describe "Splitting into lines" $ do + 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" + ] + + 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| +Hello this is a test +of the Emergency +Broadcast System|] diff --git a/tests/SimpleExperiment.hs b/tests/SimpleExperiment.hs deleted file mode 100644 --- a/tests/SimpleExperiment.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - ---import Data.Text (Text) -import Control.Concurrent (threadDelay) -import Control.Monad (replicateM_) -import qualified Data.ByteString.Char8 as S -import qualified Data.HashMap.Strict as HashMap -import Data.Text.Prettyprint.Doc (layoutPretty, defaultLayoutOptions, Pretty(..)) -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) - -import Core.Data -import Core.Text -import Core.Encoding -import Core.Program -import Core.System - -k = JsonKey "intro" -v = JsonString "Hello" - -j = JsonObject - [ (k, v) - , (JsonKey "song", JsonString "Thriller") - , ("other", "A very long name for the \"shadow of the moon\".") - , (JsonKey "four", JsonObject - [ (JsonKey "n1", r) - ]) - ] - -b = intoBytes (S.pack "{\"cost\": 4500}") - -r = JsonArray [JsonBool False, JsonNull, 42] - -data Boom = Boom - deriving Show - -instance Exception Boom - -program :: Program None () -program = do - event "Starting..." - - params <- getCommandLine - debugS "params" params - - level <- getVerbosityLevel - debugS "level" level - - name <- getProgramName - debug "programName" name - - setProgramName "hello" - - name <- getProgramName - debug "programName" name - - debugR "key" k - event "Verify internal values" - - state <- getApplicationState - debugS "state" state - - let x = encodeToUTF8 j - writeS x - - let (Just y) = decodeFromUTF8 b - writeS y - writeS (encodeToUTF8 y) - writeR (encodeToUTF8 y) - writeS (encodeToUTF8 r) - - debugR "packet" j - - event "Clock..." - - fork $ do - sleep 1.5 - event "Wakey wakey" - throw Boom - - replicateM_ 5 $ do - sleep 0.5 - event "tick" - - - event "Brr! It's cold" - terminate 0 - -version :: Version -version = $(fromPackage) - -main :: IO () -main = do - context <- configure version None (simple - [ Option "quiet" (Just 'q') Empty [quote| - Supress normal output. - |] - , Argument "filename" [quote| - The file you want to frobnicate. - |] - , Variable "HOME" "Home directory" - ]) - - executeWith context program diff --git a/tests/Snippet.hs b/tests/Snippet.hs deleted file mode 100644 --- a/tests/Snippet.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -import qualified Data.ByteString.Char8 as C - -import Core.Program -import Core.Text -import Core.System - -b = intoBytes (C.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") - -data Boom = Boom deriving Show -instance Exception Boom - -main :: IO () -main = execute $ do - event "Processing..." - debugR "b" b - - let x = error "No!" - - write $ case x of - Nothing -> "Nothing!" - - sleep 0.2 - - write "Done" diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -2,6 +2,7 @@ import Test.Hspec +import Core.System import CheckRopeBehaviour import CheckBytesBehaviour import CheckContainerBehaviour @@ -11,8 +12,7 @@ main :: IO () main = do - hspec suite - putStrLn "." + finally (hspec suite) (putStrLn ".") suite :: Spec suite = do diff --git a/unbeliever.cabal b/unbeliever.cabal --- a/unbeliever.cabal +++ b/unbeliever.cabal @@ -1,260 +1,165 @@ cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.1. --- --- see: https://github.com/sol/hpack --- --- hash: dc4af83e0e28d0d48d8e6550b7def407de3c5e3cc34d5c6380ecbfdc74229985 - -name: unbeliever -version: 0.8.0.0 -synopsis: Opinionated Haskell Interoperability -description: A library to help build command-line programs, both tools and - longer-running daemons. - . - A description of this package, a list of features, and some background - to its design is contained in the - - on GitHub. - . - Useful starting points in the documentation are "Core.Program.Execute" - and "Core.Text.Rope". -category: System -stability: experimental -homepage: https://github.com/oprdyn/unbeliever#readme -bug-reports: https://github.com/oprdyn/unbeliever/issues -author: Andrew Cowie -maintainer: Andrew Cowie -copyright: © 2018 Operational Dynamics Consulting Pty Ltd, and Others -license: BSD3 -license-file: LICENCE -tested-with: GHC == 8.4 -build-type: Simple +name: unbeliever +version: 0.9.2.0 +license: BSD3 +license-file: LICENCE +copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others +maintainer: Andrew Cowie +author: Andrew Cowie +stability: experimental +tested-with: ghc ==8.6.4 +homepage: https://github.com/oprdyn/unbeliever#readme +bug-reports: https://github.com/oprdyn/unbeliever/issues +synopsis: Opinionated Haskell Interoperability +description: + A library to help build command-line programs, both tools and + longer-running daemons. + . + A description of this package, a list of features, and some background + to its design is contained in the + + on GitHub. + . + Useful starting points in the documentation are "Core.Program.Execute" + and "Core.Text.Rope". +category: System +build-type: Simple source-repository head - type: git - location: https://github.com/oprdyn/unbeliever - -flag development - manual: True - default: False + type: git + location: https://github.com/oprdyn/unbeliever library - exposed-modules: - Core.Data - Core.Data.Structures - Core.Encoding - Core.Encoding.Json - Core.Program - Core.Program.Arguments - Core.Program.Execute - Core.Program.Logging - Core.Program.Metadata - Core.Program.Unlift - Core.Text - Core.Text.Bytes - Core.Text.Rope - Core.Text.Utilities - Core.System - Core.System.Base - Core.System.External - other-modules: - Core.Program.Context - Core.Program.Signal - hs-source-dirs: - lib - ghc-options: -Wall -Wwarn -fwarn-tabs - build-depends: - Cabal - , aeson - , async - , base >=4.11 && <5 - , bytestring - , chronologique - , containers - , deepseq - , directory - , exceptions - , fingertree - , hashable - , hourglass - , mtl - , prettyprinter - , prettyprinter-ansi-terminal - , safe-exceptions - , scientific - , stm - , template-haskell - , terminal-size - , text - , text-short - , transformers - , unix - , unordered-containers - , vector - default-language: Haskell2010 - -executable experiment - main-is: SimpleExperiment.hs - hs-source-dirs: - tests - ghc-options: -Wall -Wwarn -fwarn-tabs -threaded - build-depends: - Cabal - , aeson - , async - , base >=4.11 && <5 - , bytestring - , chronologique - , containers - , deepseq - , directory - , exceptions - , fingertree - , hashable - , hourglass - , mtl - , prettyprinter - , prettyprinter-ansi-terminal - , safe-exceptions - , scientific - , stm - , template-haskell - , terminal-size - , text - , text-short - , transformers - , unbeliever - , unix - , unordered-containers - , vector - if flag(development) - ghc-prof-options: -fprof-auto-top - buildable: True - else - buildable: False - default-language: Haskell2010 - -executable snippet - main-is: Snippet.hs - hs-source-dirs: - tests - ghc-options: -Wall -Wwarn -fwarn-tabs -threaded - build-depends: - Cabal - , aeson - , async - , base >=4.11 && <5 - , bytestring - , chronologique - , containers - , deepseq - , directory - , exceptions - , fingertree - , hashable - , hourglass - , mtl - , prettyprinter - , prettyprinter-ansi-terminal - , safe-exceptions - , scientific - , stm - , template-haskell - , terminal-size - , text - , text-short - , transformers - , unbeliever - , unix - , unordered-containers - , vector - if flag(development) - ghc-prof-options: -fprof-auto-top - buildable: True - else - buildable: False - default-language: Haskell2010 + exposed-modules: + Core.Data + Core.Data.Structures + Core.Encoding + Core.Encoding.Json + Core.Program + Core.Program.Arguments + Core.Program.Execute + Core.Program.Logging + Core.Program.Metadata + Core.Program.Unlift + Core.Text + Core.Text.Bytes + Core.Text.Rope + Core.Text.Utilities + Core.System + Core.System.Base + Core.System.External + hs-source-dirs: lib + other-modules: + Core.Program.Context + Core.Program.Signal + default-language: Haskell2010 + ghc-options: -Wall -Wwarn -fwarn-tabs + build-depends: + Cabal >=2.4.1.0 && <2.5, + aeson >=1.4.2.0 && <1.5, + async >=2.2.1 && <2.3, + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + exceptions >=0.10.0 && <0.11, + fingertree >=0.1.4.2 && <0.2, + hashable >=1.2.7.0 && <1.3, + hourglass >=0.2.12 && <0.3, + mtl >=2.2.2 && <2.3, + prettyprinter >=1.2.1 && <1.3, + prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, + safe-exceptions >=0.1.7.0 && <0.2, + scientific >=0.3.6.2 && <0.4, + stm >=2.5.0.0 && <2.6, + template-haskell >=2.14.0.0 && <2.15, + terminal-size >=0.3.2.1 && <0.4, + text >=1.2.3.1 && <1.3, + text-short >=0.1.2 && <0.2, + transformers >=0.5.6.2 && <0.6, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3, + vector >=0.12.0.2 && <0.13 test-suite check - type: exitcode-stdio-1.0 - main-is: TestSuite.hs - other-modules: - CheckArgumentsParsing - CheckBytesBehaviour - CheckContainerBehaviour - CheckJsonWrapper - CheckProgramMonad - CheckRopeBehaviour - hs-source-dirs: - tests - ghc-options: -Wall -Wwarn -fwarn-tabs -threaded - build-depends: - Cabal - , aeson - , async - , base >=4.11 && <5 - , bytestring - , chronologique - , containers - , deepseq - , directory - , exceptions - , fingertree - , hashable - , hourglass - , hspec - , mtl - , prettyprinter - , prettyprinter-ansi-terminal - , safe-exceptions - , scientific - , stm - , template-haskell - , terminal-size - , text - , text-short - , transformers - , unbeliever - , unix - , unordered-containers - , vector - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: tests + other-modules: + CheckArgumentsParsing + CheckBytesBehaviour + CheckContainerBehaviour + CheckJsonWrapper + CheckProgramMonad + CheckRopeBehaviour + default-language: Haskell2010 + ghc-options: -Wall -Wwarn -fwarn-tabs -threaded + build-depends: + Cabal >=2.4.1.0 && <2.5, + aeson >=1.4.2.0 && <1.5, + async >=2.2.1 && <2.3, + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + exceptions >=0.10.0 && <0.11, + fingertree >=0.1.4.2 && <0.2, + hashable >=1.2.7.0 && <1.3, + hourglass >=0.2.12 && <0.3, + hspec >=2.6.1 && <2.7, + mtl >=2.2.2 && <2.3, + prettyprinter >=1.2.1 && <1.3, + prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, + safe-exceptions >=0.1.7.0 && <0.2, + scientific >=0.3.6.2 && <0.4, + stm >=2.5.0.0 && <2.6, + template-haskell >=2.14.0.0 && <2.15, + terminal-size >=0.3.2.1 && <0.4, + text >=1.2.3.1 && <1.3, + text-short >=0.1.2 && <0.2, + transformers >=0.5.6.2 && <0.6, + unbeliever -any, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3, + vector >=0.12.0.2 && <0.13 benchmark performance - type: exitcode-stdio-1.0 - main-is: GeneralPerformance.hs - hs-source-dirs: - bench - ghc-options: -Wall -Wwarn -fwarn-tabs -threaded - build-depends: - Cabal - , aeson - , async - , base >=4.11 && <5 - , bytestring - , chronologique - , containers - , deepseq - , directory - , exceptions - , fingertree - , gauge - , hashable - , hourglass - , mtl - , prettyprinter - , prettyprinter-ansi-terminal - , safe-exceptions - , scientific - , stm - , template-haskell - , terminal-size - , text - , text-short - , transformers - , unbeliever - , unix - , unordered-containers - , vector - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: GeneralPerformance.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall -Wwarn -fwarn-tabs -threaded + build-depends: + Cabal >=2.4.1.0 && <2.5, + aeson >=1.4.2.0 && <1.5, + async >=2.2.1 && <2.3, + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + exceptions >=0.10.0 && <0.11, + fingertree >=0.1.4.2 && <0.2, + gauge >=0.2.4 && <0.3, + hashable >=1.2.7.0 && <1.3, + hourglass >=0.2.12 && <0.3, + mtl >=2.2.2 && <2.3, + prettyprinter >=1.2.1 && <1.3, + prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, + safe-exceptions >=0.1.7.0 && <0.2, + scientific >=0.3.6.2 && <0.4, + stm >=2.5.0.0 && <2.6, + template-haskell >=2.14.0.0 && <2.15, + terminal-size >=0.3.2.1 && <0.4, + text >=1.2.3.1 && <1.3, + text-short >=0.1.2 && <0.2, + transformers >=0.5.6.2 && <0.6, + unbeliever -any, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3, + vector >=0.12.0.2 && <0.13