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

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

Test coverage for text

1 files changed, 172 insertions, 0 deletions

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
+                    ]