diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ +1.3.0 +------------ +* fix row/column rendering in comment shapes + (thanks to Tom Ellis for reporting) +* support for monad of no return (thanks to Kevin Brubeck Unhammer ) +* dropped support for GHC 9.2.* and 9.4.* and added support for GHC 9.10.* and 9.12.* + 1.2.0 ------------ * expose sheet state in stream parser diff --git a/src/Codec/Xlsx/Parser/Internal/Fast.hs b/src/Codec/Xlsx/Parser/Internal/Fast.hs --- a/src/Codec/Xlsx/Parser/Internal/Fast.hs +++ b/src/Codec/Xlsx/Parser/Internal/Fast.hs @@ -42,7 +42,6 @@ import qualified Data.ByteString.Unsafe as SU import Data.Char (chr) import Data.Maybe -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -76,7 +75,6 @@ either (const $ g ns) Right (f ns) instance Monad ChildCollector where - return = pure ChildCollector f >>= g = ChildCollector $ \ns -> either Left (\(!ns', f') -> runChildCollector (g f') ns') (f ns) @@ -153,12 +151,11 @@ } instance Monad AttrParser where - return a = AttrParser $ \as -> Right (as, a) (AttrParser f) >>= g = AttrParser $ \as -> either Left (\(as', f') -> runAttrParser (g f') as') (f as) instance Applicative AttrParser where - pure = return + pure a = AttrParser $ \as -> Right (as, a) (<*>) = ap instance Functor AttrParser where fmap = liftM diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Codec.Xlsx.Types.Common ( CellRef(..) @@ -33,6 +32,8 @@ , fromRange , fromRange' , fromForeignRange + , SheetName + , mkSheetName , SqRef(..) , XlsxText(..) , xlsxTextToCellValue @@ -46,6 +47,7 @@ , col2int , columnIndexToText , textToColumnIndex + , rowIndexToText -- ** prisms , _XlsxText , _XlsxRichText @@ -67,23 +69,23 @@ import Data.Bifunctor (bimap) import qualified Data.ByteString as BS import Data.Char -import Data.Maybe (isJust, fromMaybe) import Data.Function ((&)) import Data.Ix (inRange) import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Calendar (Day, addDays, diffDays, fromGregorian) -import Data.Time.Clock (UTCTime(UTCTime), picosecondsToDiffTime) +import Data.Time.Clock (UTCTime (UTCTime), picosecondsToDiffTime) import Safe import Text.XML import Text.XML.Cursor +import Codec.Xlsx.LensCompat (Prism', prism) import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal -import Codec.Xlsx.LensCompat (Prism', prism) newtype RowIndex = RowIndex {unRowIndex :: Int} deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral) @@ -228,7 +230,7 @@ fromSingleCellRefRaw :: Text -> Maybe (RowIndex, ColumnIndex) fromSingleCellRefRaw = - fmap (first unRowCoord . second unColumnCoord) . fromSingleCellRefRaw' + fmap (bimap unRowCoord unColumnCoord) . fromSingleCellRefRaw' fromSingleCellRefRaw' :: Text -> Maybe CellCoord fromSingleCellRefRaw' t' = ignoreRefSheetName t' >>= \t -> do @@ -277,8 +279,8 @@ ignoreRefSheetName t = case T.split (== '!') t of [_, r] -> Just r - [r] -> Just r - _ -> Nothing + [r] -> Just r + _ -> Nothing -- | Render a single cell existing in another worksheet. -- This function always renders the sheet name single-quoted regardless the presence of spaces. @@ -349,6 +351,29 @@ [sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromRange' (CellRef ref) _ -> Nothing +-- | Name of a worksheet in the supporting workbook +-- +-- See 18.14.15 "sheetName (Sheet Name)" +newtype SheetName = SheetName {unSheetName :: Text} + deriving (Eq, Ord, Show, Generic) + +instance NFData SheetName + +-- Smart constructor to create a SheetName from a given text following a set of validators. +-- +-- 1. The character count MUST be >= 1 and <= 31. +-- 2. The string MUST NOT contain the any of the following characters: +-- '\0', '\x03', ':', '\\', '*', '?', '/', '[', ']' +-- 3. The string MUST NOT begin or end with the single quote(') character. +mkSheetName :: Text -> Maybe SheetName +mkSheetName t + | T.length t < 1 || T.length t > 31 = Nothing + | T.any (`elem` forbiddenChars) t = Nothing + | T.isPrefixOf "'" t || T.isSuffixOf "'" t = Nothing + | otherwise = Just (SheetName t) + where + forbiddenChars = ['\0', '\x03', ':', '\\', '*', '?', '/', '[', ']'] + -- | A sequence of cell references -- -- See 18.18.76 "ST_Sqref (Reference Sequence)" (p.2488) @@ -382,7 +407,7 @@ instance NFData XlsxText xlsxTextToCellValue :: XlsxText -> CellValue -xlsxTextToCellValue (XlsxText txt) = CellText txt +xlsxTextToCellValue (XlsxText txt) = CellText txt xlsxTextToCellValue (XlsxRichText rich) = CellRich rich -- | A formula @@ -408,7 +433,6 @@ | CellError ErrorType deriving (Eq, Ord, Show, Generic) - instance NFData CellValue -- | The evaluation of an expression can result in an error having one @@ -559,7 +583,7 @@ Nothing -> case rs of [] -> Left $ "missing rich text subelements" - _ -> return $ XlsxRichText rs + _ -> return $ XlsxRichText rs instance FromAttrVal CellRef where fromAttrVal = fmap (first CellRef) . fromAttrVal @@ -595,23 +619,23 @@ instance FromAttrVal ErrorType where fromAttrVal "#DIV/0!" = readSuccess ErrorDiv0 - fromAttrVal "#N/A" = readSuccess ErrorNA - fromAttrVal "#NAME?" = readSuccess ErrorName - fromAttrVal "#NULL!" = readSuccess ErrorNull - fromAttrVal "#NUM!" = readSuccess ErrorNum - fromAttrVal "#REF!" = readSuccess ErrorRef + fromAttrVal "#N/A" = readSuccess ErrorNA + fromAttrVal "#NAME?" = readSuccess ErrorName + fromAttrVal "#NULL!" = readSuccess ErrorNull + fromAttrVal "#NUM!" = readSuccess ErrorNum + fromAttrVal "#REF!" = readSuccess ErrorRef fromAttrVal "#VALUE!" = readSuccess ErrorValue - fromAttrVal t = invalidText "ErrorType" t + fromAttrVal t = invalidText "ErrorType" t instance FromAttrBs ErrorType where fromAttrBs "#DIV/0!" = return ErrorDiv0 - fromAttrBs "#N/A" = return ErrorNA - fromAttrBs "#NAME?" = return ErrorName - fromAttrBs "#NULL!" = return ErrorNull - fromAttrBs "#NUM!" = return ErrorNum - fromAttrBs "#REF!" = return ErrorRef + fromAttrBs "#N/A" = return ErrorNA + fromAttrBs "#NAME?" = return ErrorName + fromAttrBs "#NULL!" = return ErrorNull + fromAttrBs "#NUM!" = return ErrorNum + fromAttrBs "#REF!" = return ErrorRef fromAttrBs "#VALUE!" = return ErrorValue - fromAttrBs x = unexpectedAttrBs "ErrorType" x + fromAttrBs x = unexpectedAttrBs "ErrorType" x {------------------------------------------------------------------------------- Rendering @@ -640,12 +664,12 @@ toElement nm (Formula txt) = elementContent nm txt instance ToAttrVal ErrorType where - toAttrVal ErrorDiv0 = "#DIV/0!" - toAttrVal ErrorNA = "#N/A" - toAttrVal ErrorName = "#NAME?" - toAttrVal ErrorNull = "#NULL!" - toAttrVal ErrorNum = "#NUM!" - toAttrVal ErrorRef = "#REF!" + toAttrVal ErrorDiv0 = "#DIV/0!" + toAttrVal ErrorNA = "#N/A" + toAttrVal ErrorName = "#NAME?" + toAttrVal ErrorNull = "#NULL!" + toAttrVal ErrorNum = "#NUM!" + toAttrVal ErrorRef = "#REF!" toAttrVal ErrorValue = "#VALUE!" -- Since micro-lens denies the existence of prisms, @@ -660,7 +684,7 @@ (\ x_a1ZQw -> case x_a1ZQw of CellText y1_a1ZQx -> Right y1_a1ZQx - _ -> Left x_a1ZQw) + _ -> Left x_a1ZQw) {-# INLINE _CellText #-} _CellDouble :: Prism' CellValue Double _CellDouble @@ -668,7 +692,7 @@ (\ x_a1ZQz -> case x_a1ZQz of CellDouble y1_a1ZQA -> Right y1_a1ZQA - _ -> Left x_a1ZQz) + _ -> Left x_a1ZQz) {-# INLINE _CellDouble #-} _CellBool :: Prism' CellValue Bool _CellBool @@ -676,7 +700,7 @@ (\ x_a1ZQC -> case x_a1ZQC of CellBool y1_a1ZQD -> Right y1_a1ZQD - _ -> Left x_a1ZQC) + _ -> Left x_a1ZQC) {-# INLINE _CellBool #-} _CellRich :: Prism' CellValue [RichTextRun] _CellRich @@ -684,7 +708,7 @@ (\ x_a1ZQF -> case x_a1ZQF of CellRich y1_a1ZQG -> Right y1_a1ZQG - _ -> Left x_a1ZQF) + _ -> Left x_a1ZQF) {-# INLINE _CellRich #-} _CellError :: Prism' CellValue ErrorType _CellError @@ -692,7 +716,7 @@ (\ x_a1ZQI -> case x_a1ZQI of CellError y1_a1ZQJ -> Right y1_a1ZQJ - _ -> Left x_a1ZQI) + _ -> Left x_a1ZQI) {-# INLINE _CellError #-} _XlsxText :: Prism' XlsxText Text @@ -701,7 +725,7 @@ (\ x_a1ZzV -> case x_a1ZzV of XlsxText y1_a1ZzW -> Right y1_a1ZzW - _ -> Left x_a1ZzV) + _ -> Left x_a1ZzV) {-# INLINE _XlsxText #-} _XlsxRichText :: Prism' XlsxText [RichTextRun] _XlsxRichText @@ -709,5 +733,5 @@ (\ x_a1ZzY -> case x_a1ZzY of XlsxRichText y1_a1ZzZ -> Right y1_a1ZzZ - _ -> Left x_a1ZzY) + _ -> Left x_a1ZzY) {-# INLINE _XlsxRichText #-} diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -118,10 +118,10 @@ , "" , "4, 15, 0, 7, 6, 31, 5, 1False" , "" - , LBC8.pack $ show (r - 1) + , LBC8.pack $ show (unRowIndex r - 1) , "" , "" - , LBC8.pack $ show (c - 1) + , LBC8.pack $ show (unColumnIndex c - 1) , "" , "" , "" diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs --- a/src/Codec/Xlsx/Types/RichText.hs +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -342,6 +342,7 @@ -- override earlier ones. instance Monoid RunProperties where mempty = def +#if !(MIN_VERSION_base(4,11,0)) a `mappend` b = RunProperties { _runPropertiesBold = override _runPropertiesBold , _runPropertiesCharset = override _runPropertiesCharset @@ -362,6 +363,7 @@ where override :: (RunProperties -> Maybe x) -> Maybe x override f = f b `mplus` f a +#endif -- | Apply properties to a 'RichTextRun' -- diff --git a/test/StreamTests.hs b/test/StreamTests.hs --- a/test/StreamTests.hs +++ b/test/StreamTests.hs @@ -186,40 +186,20 @@ where sheet = toWs $ [1..2] >>= \row -> [((row,1), a1) - , ((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) + , ((row,2), def & cellValue ?~ CellText ("text at B"<> rowIndexToText row <> " Sheet1")) , ((row,3), def & cellValue ?~ CellText "text at C1 Sheet1") , ((row,4), def & cellValue ?~ CellDouble (0.2 + 0.1)) , ((row,5), def & cellValue ?~ CellBool False) ] --- sheets = [("Sheet1" , toWs $ [1..2] >>= \row -> --- [ ((RowIndex row, ColumnIndex 1), a1) --- , ((RowIndex row, ColumnIndex 2), --- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) --- , ((RowIndex row, ColumnIndex 3), --- def & cellValue ?~ CellText "text at C1 Sheet1") --- , ((RowIndex row, ColumnIndex 4), --- def & cellValue ?~ CellDouble (0.2 + 0.1)) --- , ((RowIndex row, ColumnIndex 5), --- def & cellValue ?~ CellBool False) --- ] --- )] bigWorkbook :: Xlsx bigWorkbook = def & atSheet "Sheet1" ?~ sheet where sheet = toWs $ [1..512] >>= \row -> [((row,1), a1) - ,((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) + ,((row,2), def & cellValue ?~ CellText ("text at B"<> rowIndexToText row <> " Sheet1")) ,((row,3), def & cellValue ?~ CellText "text at C1 Sheet1") ] --- sheets = [("Sheet1" , toWs $ [1..512] >>= \row -> --- [((RowIndex row, ColumnIndex 1), a1) --- ,((RowIndex row, ColumnIndex 2), --- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) --- ,((RowIndex row, ColumnIndex 3), --- def & cellValue ?~ CellText "text at C1 Sheet1") --- ] --- )] multipleSheetsWorkbook :: Xlsx multipleSheetsWorkbook = simpleWorkbook diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 1.2.0 +Version: 1.3.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -28,7 +28,7 @@ Category: Codec Build-type: Simple -Tested-with: GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4 +Tested-with: GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.3 GHC == 9.12.4 Cabal-version: >=1.10 Flag microlens @@ -96,7 +96,6 @@ , Codec.Xlsx.LensCompat Build-depends: base >= 4.9.0.0 && < 5.0 - , attoparsec , base64-bytestring , binary-search , bytestring >= 0.10.8.0 @@ -111,16 +110,13 @@ , hexpat , mtl >= 2.1 , network-uri - , old-locale >= 1.0.0.5 , safe >= 0.3 , text >= 0.11.3.1 , time >= 1.4.0.1 - , transformers >= 0.3.0.0 , vector >= 0.10 , xeno >= 0.3.2 , xml-conduit >= 1.1.0 , zip-archive >= 0.2 - , zlib >= 0.5.4.0 , zip , zip-stream >= 0.2.0.1 , xml-types @@ -197,7 +193,7 @@ source-repository head type: git - location: git://github.com/qrilka/xlsx.git + location: https://github.com/qrilka/xlsx.git benchmark bench type: exitcode-stdio-1.0