diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ +0.8.0 +------ +* GHC 8.8 compatibility added (GHC 8.6 didn't need any updates). Dropped + compatilibity with GHC 7.10 + (thanks to David Hewson ) + 0.7.2 ----- * GHC 8.4 compatibility diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -8,6 +8,7 @@ , Formatted(..) , Format(..) , formatted + , formatWorkbook , toFormattedCells , CondFormatted(..) , conditionallyFormatted @@ -72,7 +73,7 @@ , _formattingCellXfs = fromValueList _styleSheetCellXfs , _formattingFills = fromValueList _styleSheetFills , _formattingFonts = fromValueList _styleSheetFonts - , _formattingNumFmts = M.empty + , _formattingNumFmts = M.fromList . map swap $ M.toList _styleSheetNumFmts , _formattingMerges = [] } @@ -235,6 +236,21 @@ , formattedStyleSheet = styleSheet' , formattedMerges = reverse (finalSt ^. formattingMerges) } + +formatWorkbook :: [(Text, Map (Int, Int) FormattedCell)] -> StyleSheet -> Xlsx +formatWorkbook nfcss initStyle = extract go + where + initSt = stateFromStyleSheet initStyle + go = flip runState initSt $ + forM nfcss $ \(name, fcs) -> do + cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc + merges <- reverse . _formattingMerges <$> get + return ( name + , def & wsCells .~ M.fromList (concat cs') + & wsMerges .~ merges) + extract (sheets, st) = + def & xlSheets .~ sheets + & xlStyles .~ renderStyleSheet (updateStyleSheetFromState initStyle st) -- | reverse to 'formatted' which allows to get a map of formatted cells -- from an existing worksheet and its workbook's style sheet 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 @@ -35,6 +35,7 @@ import Control.Arrow (second) import Control.Exception (Exception, throw) import Control.Monad (ap, forM, join, liftM) +import Data.Bifunctor (first) import Data.Bits ((.|.), shiftL) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -224,11 +225,11 @@ instance FromAttrBs Int where -- it appears that parser in text is more optimized than the one in -- attoparsec at least as of text-1.2.2.2 and attoparsec-0.13.1.0 - fromAttrBs = decimal . T.decodeLatin1 + fromAttrBs = first T.pack . eitherDecimal . T.decodeLatin1 instance FromAttrBs Double where -- as for rationals - fromAttrBs = rational . T.decodeLatin1 + fromAttrBs = first T.pack . eitherRational . T.decodeLatin1 instance FromAttrBs Text where fromAttrBs = replaceEntititesBs diff --git a/src/Codec/Xlsx/Parser/Internal/Util.hs b/src/Codec/Xlsx/Parser/Internal/Util.hs --- a/src/Codec/Xlsx/Parser/Internal/Util.hs +++ b/src/Codec/Xlsx/Parser/Internal/Util.hs @@ -1,26 +1,43 @@ -{-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Parser.Internal.Util ( boolean + , eitherBoolean , decimal + , eitherDecimal , rational + , eitherRational ) where import Data.Text (Text) +import Control.Monad.Fail (MonadFail) import qualified Data.Text as T import qualified Data.Text.Read as T +import qualified Control.Monad.Fail as F -decimal :: (Monad m, Integral a) => Text -> m a -decimal t = case T.signed T.decimal $ t of - Right (d, leftover) | T.null leftover -> return d - _ -> fail $ "invalid decimal" ++ show t +decimal :: (MonadFail m, Integral a) => Text -> m a +decimal = fromEither . eitherDecimal -rational :: Monad m => Text -> m Double -rational t = case T.signed T.rational t of - Right (r, leftover) | T.null leftover -> return r - _ -> fail $ "invalid rational: " ++ show t +eitherDecimal :: (Integral a) => Text -> Either String a +eitherDecimal t = case T.signed T.decimal t of + Right (d, leftover) | T.null leftover -> Right d + _ -> Left $ "invalid decimal: " ++ show t -boolean :: Monad m => Text -> m Bool -boolean t = case T.strip t of - "true" -> return True - "false" -> return False - _ -> fail $ "invalid boolean: " ++ show t +rational :: (MonadFail m) => Text -> m Double +rational = fromEither . eitherRational + +eitherRational :: Text -> Either String Double +eitherRational t = case T.signed T.rational t of + Right (r, leftover) | T.null leftover -> Right r + _ -> Left $ "invalid rational: " ++ show t + +boolean :: (MonadFail m) => Text -> m Bool +boolean = fromEither . eitherBoolean + +eitherBoolean :: Text -> Either String Bool +eitherBoolean t = case T.unpack $ T.strip t of + "true" -> Right True + "false" -> Right False + _ -> Left $ "invalid boolean: " ++ show t + +fromEither :: (MonadFail m) => Either String b -> m b +fromEither (Left a) = F.fail a +fromEither (Right b) = return b diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs --- a/src/Codec/Xlsx/Types/Drawing/Common.hs +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -9,6 +9,7 @@ import Control.Arrow (first) import Control.Lens.TH import Control.Monad (join) +import Control.Monad.Fail (MonadFail) import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, listToMaybe) @@ -462,7 +463,7 @@ return $ RgbColor val | otherwise = fail "no matching color choice node" -coordinate :: Monad m => Text -> m Coordinate +coordinate :: MonadFail m => Text -> m Coordinate coordinate t = case T.decimal t of Right (d, leftover) | leftover == T.empty -> return $ UnqCoordinate d 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 @@ -245,7 +245,8 @@ , elementValue "extend" <$> _runPropertiesExtend , toElement "color" <$> _runPropertiesColor , elementValue "sz" <$> _runPropertiesSize - , elementValue "u" <$> _runPropertiesUnderline + , elementValueDef "u" FontUnderlineSingle + <$> _runPropertiesUnderline , elementValue "vertAlign" <$> _runPropertiesVertAlign , elementValue "scheme" <$> _runPropertiesScheme ] @@ -284,7 +285,7 @@ _runPropertiesExtend <- maybeBoolElementValue (n_ "extend") cur _runPropertiesColor <- maybeFromElement (n_ "color") cur _runPropertiesSize <- maybeElementValue (n_ "sz") cur - _runPropertiesUnderline <- maybeElementValue (n_ "u") cur + _runPropertiesUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur _runPropertiesVertAlign <- maybeElementValue (n_ "vertAlign") cur _runPropertiesScheme <- maybeElementValue (n_ "scheme") cur return RunProperties{..} diff --git a/src/Codec/Xlsx/Types/Variant.hs b/src/Codec/Xlsx/Types/Variant.hs --- a/src/Codec/Xlsx/Types/Variant.hs +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -3,6 +3,7 @@ module Codec.Xlsx.Types.Variant where import Control.DeepSeq (NFData) +import Control.Monad.Fail (MonadFail) import Data.ByteString (ByteString) import Data.ByteString.Base64 as B64 import Data.Text (Text) @@ -52,7 +53,7 @@ killWhitespace :: Text -> Text killWhitespace = T.filter (/=' ') -decodeBase64 :: Monad m => Text -> m ByteString +decodeBase64 :: MonadFail m => Text -> m ByteString decodeBase64 t = case B64.decode (T.encodeUtf8 t) of Right bs -> return bs Left err -> fail $ "invalid base64 value: " ++ err diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -21,6 +21,7 @@ , elementContent , elementContentPreserved , elementValue + , elementValueDef -- * Rendering attributes , ToAttrVal(..) , (.=) @@ -39,6 +40,7 @@ ) where import qualified Data.Map as Map +import Data.Maybe (catMaybes) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -143,11 +145,11 @@ toAttrVal False = "0" elementValue :: ToAttrVal a => Name -> a -> Element -elementValue nm a = Element { - elementName = nm - , elementAttributes = Map.fromList [ "val" .= a ] - , elementNodes = [] - } +elementValue nm a = leafElement nm [ "val" .= a ] + +elementValueDef :: (Eq a, ToAttrVal a) => Name -> a -> a -> Element +elementValueDef nm defVal a = + leafElement nm $ catMaybes [ "val" .=? justNonDef defVal a ] (.=) :: ToAttrVal a => Name -> a -> (Name, Text) nm .= a = (nm, toAttrVal a) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} module Main @@ -54,6 +55,10 @@ testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) , testCase "correct shared strings parsing" $ [testSharedStringTable] @=? parseBS testStrings + , testCase "correct shared strings parsing: single underline" $ + [withSingleUnderline testSharedStringTable] @=? parseBS testStringsWithSingleUnderline + , testCase "correct shared strings parsing: double underline" $ + [withDoubleUnderline testSharedStringTable] @=? parseBS testStringsWithDoubleUnderline , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty , testCase "correct comments parsing" $ @@ -62,6 +67,8 @@ [testCustomProperties] @==? parseBS testCustomPropertiesXml , testCase "proper results from `formatted`" $ testFormattedResult @==? testRunFormatted + , testCase "proper results from `formatWorkbook`" $ + testFormatWorkbookResult @==? testFormatWorkbook , testCase "formatted . toFormattedCells = id" $ do let fmtd = formatted testFormattedCells minimalStyleSheet testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) @@ -251,6 +258,18 @@ { _cellXfApplyNumberFormat = Just True , _cellXfNumFmtId = Just 164 } + +withSingleUnderline :: SharedStringTable -> SharedStringTable +withSingleUnderline = withUnderline FontUnderlineSingle + +withDoubleUnderline :: SharedStringTable -> SharedStringTable +withDoubleUnderline = withUnderline FontUnderlineDouble + +withUnderline :: FontUnderline -> SharedStringTable -> SharedStringTable +withUnderline u (SharedStringTable [text, XlsxRichText [rich1, RichTextRun (Just props) val]]) = + let newprops = props & runPropertiesUnderline .~ Just u + in SharedStringTable [text, XlsxRichText [rich1, RichTextRun (Just newprops) val]] + testSharedStringTable :: SharedStringTable testSharedStringTable = SharedStringTable $ V.fromList items where @@ -259,7 +278,7 @@ rich = XlsxRichText [ RichTextRun Nothing "Just " , RichTextRun (Just props) "example" ] props = def & runPropertiesBold .~ Just True - & runPropertiesUnderline .~ Just FontUnderlineSingle + & runPropertiesItalic .~ Just True & runPropertiesSize .~ Just 10 & runPropertiesFont .~ Just "Arial" & runPropertiesFontFamily .~ Just FontFamilySwiss @@ -295,10 +314,26 @@ testStrings = "\ \\ \plain text\ - \Just \ + \Just \ \example\ \" +testStringsWithSingleUnderline :: ByteString +testStringsWithSingleUnderline = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + +testStringsWithDoubleUnderline :: ByteString +testStringsWithDoubleUnderline = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + testStringsWithEmpty :: ByteString testStringsWithEmpty = "\ \\ @@ -435,6 +470,41 @@ & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) + +testFormatWorkbookResult :: Xlsx +testFormatWorkbookResult = def & xlSheets .~ sheets + & xlStyles .~ renderStyleSheet style + where + testCellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing + , _cellValue = Just (CellText "text at A1 Sheet1") + , _cellComment = Nothing + , _cellFormula = Nothing })] + testCellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing })] + sheets = [ ("Sheet1", def & wsCells .~ testCellMap1) + , ("Sheet2", def & wsCells .~ testCellMap2) + ] + style = minimalStyleSheet & styleSheetNumFmts .~ M.fromList [(164, "DD.MM.YYYY")] + & styleSheetCellXfs .~ [cellXf1, cellXf2] + cellXf1 = def + & cellXfBorderId .~ Just 0 + & cellXfFillId .~ Just 0 + & cellXfFontId .~ Just 0 + cellXf2 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + +testFormatWorkbook :: Xlsx +testFormatWorkbook = formatWorkbook sheets minimalStyleSheet + where + sheetNames = ["Sheet1", "Sheet2"] + testFormattedCellMap1 = M.fromList [((1,1), (def & formattedCell . cellValue ?~ CellText "text at A1 Sheet1"))] + + testFormattedCellMap2 = M.fromList [((2,3), (def & formattedCell . cellValue ?~ CellDouble 1.23456 + & formattedFormat . formatNumberFormat ?~ (UserNumberFormat "DD.MM.YYYY")))] + sheets = zip sheetNames [testFormattedCellMap1, testFormattedCellMap2] testCondFormattedResult :: CondFormatted testCondFormattedResult = CondFormatted styleSheet formattings diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.7.2 +Version: 0.8.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -26,7 +26,7 @@ Category: Codec Build-type: Simple -Tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 +Tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.1 Cabal-version: >=1.10 @@ -73,7 +73,7 @@ , Codec.Xlsx.Writer.Internal , Codec.Xlsx.Writer.Internal.PivotTable - Build-depends: base == 4.* + Build-depends: base >= 4.9.0.0 && < 5.0 , attoparsec , base64-bytestring , binary-search