From 8307d7e80a88f1425eb0a93bbde4adff388b7cdc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 9 Jan 2016 02:19:56 +0000 Subject: spec/src/Thermoprint/Printout.hs & test-framework Implemented Printout, Paragraph, Chunk, Block, Line, and text Test coverage for text --- spec/src/Thermoprint/Printout.hs | 172 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 172 insertions(+) create mode 100644 spec/src/Thermoprint/Printout.hs (limited to 'spec/src/Thermoprint') 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 + ] -- cgit v1.2.3