spec/src/Thermoprint/Printout.hs & test-framework

Implemented Printout, Paragraph, Chunk, Block, Line, and text

Test coverage for text

4 files changed, 197 insertions, 5 deletions

diff --git a/spec/Spec.hs b/spec/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/spec/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/spec/src/Thermoprint/Printout.hs b/spec/src/Thermoprint/Printout.hs
new file mode 100644
index 0000000..d13d02e
--- /dev/null
+++ b/spec/src/Thermoprint/Printout.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job
+module Thermoprint.Printout
+       ( Printout(..)
+       , Paragraph(..)
+       , Chunk(..)
+       , Block(..)
+       , Line( HSpace
+             , SpaceSep
+             )
+       , text, cotext
+       , prop_text
+       ) where
+
+import Data.Sequence (Seq, (|>), (<|))
+
+import Data.Text.Lazy (Text)
+
+import Data.ByteString.Lazy (ByteString)
+
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
+
+import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary, genericShrink)
+import Test.QuickCheck.Modifiers (NonNegative(..))
+import Test.QuickCheck.Gen (oneof, suchThat)
+import Test.QuickCheck.Instances
+import Test.QuickCheck (forAll, Property)
+
+
+import qualified Data.Text.Lazy as TL (lines, split, null, pack, filter, intercalate, map)
+import Data.Char (isSpace)
+
+import Data.Monoid (Monoid(..), (<>))
+
+import Data.List (dropWhile, dropWhileEnd, groupBy, genericLength, genericReplicate)
+
+import Data.Sequence as Seq (fromList, null, singleton)
+
+import Data.Function (on)
+
+import Data.Foldable (toList)
+
+
+-- | A 'Printout' is a sequence of visually seperated 'Paragraph's
+type Printout = Seq Paragraph
+
+-- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
+type Paragraph = Seq Chunk
+
+-- | We introduce both 'Chunk' and 'Paragraph' mainly to allow 'Raw'.
+-- 
+-- Were we to disallow 'Raw', 'Block' would be identical to 'Paragraph'
+data Chunk = Cooked Block -- ^ text semantically structured to be rendered in accordance with the display format of printer
+           | Raw ByteString -- ^ direct instructions to the printer
+           deriving (Generic, NFData, Show, CoArbitrary)
+
+-- | 'Block' is the entry point for our structured document format
+data Block = Line Line -- ^ a single 'Line' of text
+           | VSpace Integer -- ^ vertical space of height equivalent to 'Integer' lines
+           | NewlSep (Seq Block) -- ^ A sequence of 'Block's seperated by newlines
+           deriving (Generic, NFData, Show, CoArbitrary)
+
+{- | A 'Line' is one of:
+
+  * a single word
+  * horizontal space equivalent to the width of 'Integer' `em`.
+  * a sequence of words seperated by spaces
+
+We don't export all constructors and instead encourage the use of 'text'.
+-} 
+data Line = Word Text
+          | HSpace Integer
+          | SpaceSep (Seq Line)
+          deriving (Generic, NFData, Show, CoArbitrary)
+
+instance Monoid Block where
+  mempty = NewlSep mempty
+  x@(NewlSep xs) `mappend` y@(NewlSep ys)
+    | Seq.null xs = y
+    | Seq.null ys = x
+    | otherwise = NewlSep (xs <> ys)
+  (NewlSep xs) `mappend` y = NewlSep (xs |> y)
+  x `mappend` (NewlSep ys) = NewlSep (x <| ys)
+  x `mappend` y = NewlSep $ Seq.fromList [x, y]
+
+instance Monoid Line where
+  mempty = SpaceSep mempty
+  x@(SpaceSep xs) `mappend` y@(SpaceSep ys)
+    | Seq.null xs = y
+    | Seq.null ys = x
+    | otherwise = SpaceSep (xs <> ys)
+  (SpaceSep xs) `mappend` y = SpaceSep (xs |> y)
+  x `mappend` (SpaceSep ys) = SpaceSep (x <| ys)
+  x `mappend` y = SpaceSep $ Seq.fromList [x, y]
+
+
+text :: Text -> Either Block Line
+-- ^ Smart constructor for 'Line'/'Block' which maps word and line boundaries (as determined by 'isSpace' and 'TL.lines' respectively) to the structure of 'Block' and 'Line'.
+--
+-- Since we are unwilling to duplicate the list of chars from 'isSpace' we cannot reasonably determine a width for the various whitespace 'Char's.
+-- Thus they are all weighted equally as having width 1 `em`.
+text t = case splitLines t of
+  [] -> Right mempty
+  [Line x] -> Right x
+  xs -> Left $ mconcat xs
+  where
+    splitLines :: Text -> [Block]
+    splitLines t = map toBlock
+                   . groupBy ((==) `on` TL.null)
+                   $ TL.lines t
+    splitWords :: Text -> [Line]
+    splitWords t = map toLine
+                   . groupBy ((==) `on` TL.null)
+                   $ TL.split isSpace t
+    toBlock [] = mempty
+    toBlock xs@(x:_)
+      | TL.null x = VSpace $ genericLength xs
+      | otherwise = mconcat . map (Line . mconcat . splitWords) $ xs
+    toLine [] = mempty
+    toLine xs@(x:_)
+      | TL.null x = HSpace $ genericLength xs
+      | otherwise = mconcat . map Word $ xs
+    list :: b -> (a -> [a] -> b) -> [a] -> b
+    list c _ [] = c
+    list _ f (x:xs) = f x xs
+
+cotext :: Block -> Text
+-- ^ inverse of
+-- @
+--   either id Line . `text`
+-- @
+cotext (VSpace n) = TL.pack . genericReplicate (n - 1) $ '\n'
+cotext (NewlSep xs) =  TL.intercalate "\n" . map cotext . toList $ xs
+cotext (Line x) = cotext' x
+  where            
+    cotext' (Word x) = x
+    cotext' (HSpace n) = TL.pack . genericReplicate (n - 1) $ ' '
+    cotext' (SpaceSep xs) = TL.intercalate " " . map cotext' . toList $ xs
+
+prop_text :: Property
+-- ^ prop> cotext . either id Line . `text` $ x = x
+--
+-- Where 'x' is restricted to those `TL.Text` which do not contain whitespace besides ' ' and '\n'.
+prop_text = forAll (TL.map normSpace <$> arbitrary) $ \x -> (cotext . either id Line . text $ x) == x
+  where
+    normSpace c
+      | c == '\n' = '\n'
+      | isSpace c = ' ' -- We have to do this because all whitespace gets interpreted as width 1
+      | otherwise = c
+
+-- | We don't test 'Raw' 'Chunk's
+instance Arbitrary Chunk where
+  shrink = genericShrink
+  arbitrary = Cooked <$> arbitrary
+
+instance Arbitrary Block where
+  shrink = genericShrink
+  arbitrary = oneof [ Line <$> arbitrary
+                    , VSpace . getNonNegative <$> arbitrary
+                    , NewlSep <$> arbitrary
+                    ]
+
+instance Arbitrary Line where
+  shrink = genericShrink
+  arbitrary = oneof [ Word . TL.filter (not . isSpace) <$> arbitrary -- 'isSpace '\n' == True'
+                    , HSpace . getNonNegative <$> arbitrary
+                    , SpaceSep <$> arbitrary
+                    ]
diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal
index bde1b73..ba97420 100644
--- a/spec/thermoprint-spec.cabal
+++ b/spec/thermoprint-spec.cabal
@@ -17,9 +17,28 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
-  -- exposed-modules:     
+  hs-source-dirs:      src
+  exposed-modules:     Thermoprint.Printout
   -- other-modules:       
   -- other-extensions:    
-  build-depends:       base >=4.8 && <4.9
+  extensions:          DeriveGeneric
+                     , DeriveAnyClass
+                     , OverloadedStrings
+  build-depends:       base >=4.8.1 && <5
+                     , containers >=0.5.6 && <1
+                     , text >=1.2.1 && <2
+                     , bytestring >=0.10.6 && <1
+                     , deepseq >=1.4.1 && <2
+                     , QuickCheck >=2.8.1 && <3
+                     , quickcheck-instances >=0.3.11 && <4
+                     , Cabal >=1.22.4 && <2
+                     , cabal-test-quickcheck >=0.1.6 && <1
   -- hs-source-dirs:      
-  default-language:    Haskell2010
\ No newline at end of file
+  default-language:    Haskell2010
+
+Test-Suite tests
+  type:                exitcode-stdio-1.0
+  main-is:             Spec.hs
+  build-depends:       base >=4.8.1 && <5
+                     , thermoprint-spec -any
+                     , hspec >=2.2.1 && <3
\ No newline at end of file
diff --git a/spec/thermoprint-spec.nix b/spec/thermoprint-spec.nix
index 2d1814e..82f018a 100644
--- a/spec/thermoprint-spec.nix
+++ b/spec/thermoprint-spec.nix
@@ -1,9 +1,9 @@
-{ mkDerivation, base, stdenv }:
+{ mkDerivation, base, bytestring, containers, stdenv, text, QuickCheck, quickcheck-instances, cabal-test-quickcheck, hspec }:
 mkDerivation {
   pname = "thermoprint-spec";
   version = "1.0.0";
   src = ./.;
-  libraryHaskellDepends = [ base ];
+  libraryHaskellDepends = [ base bytestring containers text QuickCheck quickcheck-instances cabal-test-quickcheck hspec ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "A specification of the API and the payload datatypes and associated utilities";
   license = stdenv.lib.licenses.publicDomain;