diff --git a/PageIO.cabal b/PageIO.cabal --- a/PageIO.cabal +++ b/PageIO.cabal @@ -1,5 +1,5 @@ name: PageIO -version: 0.0.1 +version: 0.0.2 copyright: 2008 Audrey Tang license: BSD3 license-file: LICENSE @@ -21,3 +21,4 @@ extra-source-files: README hs-source-dirs: src category: Text +ghc-options: -O2 diff --git a/src/Text/PageIO/Extract.hs b/src/Text/PageIO/Extract.hs --- a/src/Text/PageIO/Extract.hs +++ b/src/Text/PageIO/Extract.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, RecordPuns #-} -{-# OPTIONS -fno-warn-name-shadowing #-} +{-# OPTIONS -fno-warn-name-shadowing -funbox-strict-fields #-} module Text.PageIO.Extract where import Data.Maybe @@ -13,11 +13,18 @@ deriving (Eq, Ord, Monoid) data SheetResult = MkSheetResult - { resultFields :: LabelMap Value - , resultBlocks :: LabelMap BlockResult + { resultFields :: !(LabelMap Value) + , resultBlocks :: !(LabelMap BlockResult) } deriving (Eq, Ord) +instance Monoid SheetResult where + mempty = MkSheetResult mempty mempty + mappend (MkSheetResult xf xb) (MkSheetResult yf yb) + = MkSheetResult (LM.union xf yf) (LM.unionWith mappend xb yb) + mconcat xs + = MkSheetResult (LM.unions (map resultFields xs)) (LM.unionsWith mappend (map resultBlocks xs)) + instance Show BlockResult where show (MkBlockResult []) = "[]" show (MkBlockResult rs) = concatMap prettyBlockResult rs @@ -69,7 +76,11 @@ val = pageVal $ crop patternBox page extractField :: Page -> Field -> Value -extractField page MkField{ fieldBox } = pageVal $ crop fieldBox page +extractField page MkField{ fieldBox, fieldFormat } = case fieldFormat of + FNumeric{} -> valToIntVal val + _ -> val + where + val = pageVal $ crop fieldBox page extractBlocks :: LabelMap Block -> Page -> [(Label, BlockResult)] extractBlocks blocks page@(MkPage lns) = case blockResults of diff --git a/src/Text/PageIO/LabelMap.hs b/src/Text/PageIO/LabelMap.hs --- a/src/Text/PageIO/LabelMap.hs +++ b/src/Text/PageIO/LabelMap.hs @@ -42,6 +42,12 @@ elems :: LabelMap a -> [a] elems = IM.elems . labelMap +union :: LabelMap a -> LabelMap a -> LabelMap a +union (MkLabelMap x) (MkLabelMap y) = MkLabelMap (IM.union x y) + +unionWith :: (a -> a -> a) -> LabelMap a -> LabelMap a -> LabelMap a +unionWith f (MkLabelMap x) (MkLabelMap y) = MkLabelMap (IM.unionWith f x y) + unions :: [LabelMap a] -> LabelMap a unions = MkLabelMap . IM.unions . Prelude.map labelMap @@ -72,3 +78,5 @@ mapMaybeWithKey :: (Label -> a -> Maybe b) -> LabelMap a -> LabelMap b mapMaybeWithKey f = MkLabelMap . IM.mapMaybeWithKey (f . keyToLabel) . labelMap +intersection :: LabelMap a -> LabelMap b -> LabelMap a +intersection (MkLabelMap x) (MkLabelMap y) = MkLabelMap (IM.intersection x y) diff --git a/src/Text/PageIO/Parser.hs b/src/Text/PageIO/Parser.hs --- a/src/Text/PageIO/Parser.hs +++ b/src/Text/PageIO/Parser.hs @@ -2,6 +2,7 @@ import Text.Parsec import Text.Parsec.ByteString +import Data.Char (isDigit) import Data.ByteString.Lazy.Char8 (pack, ByteString, toChunks) import Text.PageIO.Types import Control.Monad (liftM3, liftM4) @@ -10,8 +11,12 @@ import qualified Data.ByteString.Char8 as S import qualified Text.PageIO.LabelMap as LM -readSheet :: String -> IO (Either ParseError Sheet) -readSheet = parseFromFile sheet +readSheet :: FilePath -> IO Sheet +readSheet fn = do + rv <- parseFromFile sheet fn + case rv of + Right s -> return s + Left err -> fail $ show err parseMaybe :: Parser a -> Parser (Maybe a) parseMaybe r = fmap Just r <|> return Nothing @@ -20,7 +25,8 @@ maybeFieldVariable = parseMaybe $ do char '$' choice - [ sym "PAGE" >> return VPage + [ char '$' >> fmap VLabel bareLabel + , sym "PAGE" >> return VPage , literalVariable , functionVariable ] @@ -41,10 +47,15 @@ , sym "doc." >> return SDoc , return SPage ] - fld <- many1 $ noneOf ".) " + fld <- bareLabel sym ")" - return $ fun scope (toLabel fld) + return $ fun scope fld +bareLabel :: Parser Label +bareLabel = do + s <- many1 $ noneOf ".;) " + ret $ toLabel s + maybeFieldFormat :: Parser (Maybe FieldFormat) maybeFieldFormat = parseMaybe $ do sym "Format" @@ -104,6 +115,8 @@ sheet :: Parser Sheet sheet = do + sym "Event" + name <- labelStr manyTill anyChar (sym "UseCharPos" <|> sym "UseGridPos") sym "Sheet" right <- num @@ -115,7 +128,8 @@ frames <- many frame sym "End" ret $ MkSheet - { sheetBox = MkBox + { sheetName = name + , sheetBox = MkBox { boxLeft = 1 , boxTop = 1 , boxRight = right diff --git a/src/Text/PageIO/Run.hs b/src/Text/PageIO/Run.hs --- a/src/Text/PageIO/Run.hs +++ b/src/Text/PageIO/Run.hs @@ -39,7 +39,8 @@ case S.split '\x0C' content of [] -> return [] (hd:tl) -> do - let pages = map (MkPage . map dropCR . S.lines) (hd:map (S.tail . S.dropWhile (/= '\n')) tl) + let pages = map (MkPage . map dropCR . S.lines) + $ filter ((>0) . S.length) (hd:map (S.tail . S.dropWhile (/= '\n')) tl) length (pageLines $ last pages) `seq` unsafeFinalize content return pages where diff --git a/src/Text/PageIO/Transform.hs b/src/Text/PageIO/Transform.hs --- a/src/Text/PageIO/Transform.hs +++ b/src/Text/PageIO/Transform.hs @@ -1,40 +1,44 @@ {-# LANGUAGE RecordPuns, ParallelListComp, PatternGuards #-} -{-# OPTIONS -fno-warn-name-shadowing #-} +{-# OPTIONS -fno-warn-name-shadowing -funbox-strict-fields #-} module Text.PageIO.Transform where import Data.Maybe import Data.Monoid -import Data.Char (isDigit) import Data.Function (on) -import Data.List (find, inits, tails, sortBy, groupBy) +import Data.List (find, inits, tails, sortBy, groupBy, intersperse) import Text.Printf import qualified Text.PageIO.LabelMap as LM import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Text.PageIO.Types import Text.PageIO.Extract (extractPage, SheetResult(..), BlockResult(..), Area) -type Doc = [Page] +data Doc = MkDoc + { docMeta :: !SheetResult + , docContent :: !L.ByteString + } + deriving (Show, Eq, Ord) type ValueMap = LabelMap [Value] data AppliedVariable = MkAppliedVariable - { avRow :: Row - , avCol :: Col - , avValue :: Value + { avRow :: !Row + , avCol :: !Col + , avValue :: !Value } deriving (Show, Eq, Ord) data Slot = MkSlot - { slotSize :: Row - , slotBlocks :: [Label] + { slotSize :: !Row + , slotBlocks :: ![Label] } deriving (Eq, Ord, Show) type Ordered a = ([OrderBy (Maybe Value)], a) data BlockData = MkBlockData - { dataSize :: Row - , dataAreas :: [Ordered Area] + { dataSize :: !Row + , dataAreas :: ![Ordered Area] } deriving (Eq, Ord, Show) @@ -53,21 +57,59 @@ -- The actual data bound to that area. type PageBinding = LabelMap [Area] --- Turn a list of page into pages grouped by results -transformPages :: Sheet -> [Page] -> [Doc] -transformPages sheet pages = map (makeDoc sheet) docGroups +parsePages :: Sheet -> [Page] -> [Doc] +parsePages sheetIn pagesIn = map emitDoc docGroupsOut where - docGroups = case sheetGroupBy sheet of - [] -> [resultAndPages] - lbls -> groupBy ((==) `on` docKeys) resultAndPages + docGroupsOut = case sheetGroupBy sheetIn of + [] -> [resultsIn] + lbls -> groupBy ((==) `on` docKeys) resultsIn where docKeys (res, _) = map (`LM.lookup` resultFields res) lbls - resultAndPages = - [ (res, page) - | Just res <- map (extractPage sheet) pages - | page <- pages - ] + resultsIn = [ (res, page) | (Just res, page) <- map (\p -> (extractPage sheetIn p, p)) pagesIn ] +emitDoc :: [(SheetResult, Page)] -> Doc +emitDoc xs = MkDoc meta (packPages pages) + where + meta = mconcat results + results = map fst xs + pages = map snd xs + + +-- Turn a list of page into pages grouped by results +transformPages :: Sheet -> [Page] -> Sheet -> [Page] -> [Doc] +transformPages sheetIn pagesIn sheetOut pagesOut = map (makeDoc sheetOut) docGroupsOut + where + bindingsOut = concatMap (bindDoc sheetOut pagesOut) docGroupsIn + docGroupsOut = case sheetGroupBy sheetOut of + [] -> [bindingsOut] + lbls -> groupBy ((==) `on` docKeys) bindingsOut + where + docKeys MkDocBinding{ docResult } = map (`LM.lookup` resultFields docResult) lbls + docGroupsIn = case sheetGroupBy sheetIn of + [] -> [resultsIn] + lbls -> groupBy ((==) `on` docKeys) resultsIn + where + docKeys res = map (`LM.lookup` resultFields res) lbls + resultsIn = [ res | Just res <- map (extractPage sheetIn) pagesIn ] + +makeDoc :: Sheet -> [DocBinding] -> Doc +makeDoc sheetOut xs = MkDoc meta . packPages $ fillVariables sheetOut results + [ makePage sheetOut b p + | b <- map docBinding xs + | p <- map docPage xs + ] + where + meta = mconcat results + results = map docResult xs + +packPages :: [Page] -> L.ByteString +packPages ps = unpages [ L.unlines [ L.fromChunks [l] | l <- pageLines p ] | p <- ps ] + where + unpages :: [L.ByteString] -> L.ByteString + unpages [] = L.empty + unpages ss = (L.concat $ intersperse nl ss) `L.append` nl -- half as much space + where nl = L.pack "\x0C\n" + -- Using Sheet+Page as template to rewrite a page -- First, rewrite SheetResult to eliminate all Variable fields -- Next, populate all fields @@ -81,27 +123,40 @@ -- -- XXX - If data would expand, then maybe repeat the first page indefinitely? -- -makeDoc :: Sheet -> [(SheetResult, Page)] -> Doc -makeDoc sheet resultAndPages = case find (isJust . fst) pageBindings of - Just (Just bindings, boundPages) -> fillVariables sheet - [ makePage sheet b p +data DocBinding = MkDocBinding + { docResult :: !SheetResult + , docPage :: !Page + , docBinding :: !PageBinding + } + deriving (Show, Eq, Ord) + +bindDoc :: Sheet -> [Page] -> [SheetResult] -> [DocBinding] +bindDoc sheetOut pagesOut resultsIn = case find (\(x, _, _) -> isJust x) pageBindings of + Just (Just bindings, boundPages, boundResults) -> + [ MkDocBinding r p b + | r <- boundResults | b <- bindings | p <- boundPages ] - _ -> error "Impossible - cannot bind?" + _ -> [] where - results = map fst resultAndPages - pages = map snd resultAndPages - orders = sheetBlockOrderBys sheet - (capacity, attempt) = foldr (doResult sheet orders) ([], mempty) results + resultsOut = map (maybe (error "Roundtrip failed!") id . extractPage sheetOut) pagesOut + orders = sheetBlockOrderBys sheetOut + capacity = foldr (doCapacity sheetOut) [] resultsOut + attempt = foldr (doAttempt orders) mempty resultsIn capacityTails = repeatTails capacity - pageTails = repeatTails pages + pageTails = repeatTails pagesOut + resultTails = repeatTails resultsIn pageBindings = - [ (tryFit pc sortedAttempt, pages) - | pc <- capacityTails - | pages <- pageTails + [ (tryFit pc sortedAttempt, pages', results') + | pc <- capacityTails + | pages' <- pageTails + | results' <- resultTails ] - sortedAttempt = fmap (\dat -> dat{ dataAreas = sortBy (compare `on` fst) $ dataAreas dat }) attempt + sortedAttempt = (`fmap` filteredAttempt) $ \dat -> + dat{ dataAreas = sortBy (compare `on` fst) $ dataAreas dat } + filteredAttempt = attempt `LM.intersection` capacityLabels + capacityLabels = LM.fromList [ (k, ()) | k <- concatMap (concatMap slotBlocks) capacity ] -- Given "abc", generate ["", "c", "bc", "abc", "aabc", "aaabc", "aaaabc"...] repeatTails :: [a] -> [[a]] @@ -111,17 +166,21 @@ infinitePrefixes = inits (repeat x) -- We now calculate the applied vars for each page -fillVariables :: Sheet -> Doc -> Doc -fillVariables sheet pages = +fillVariables :: Sheet -> [SheetResult] -> [Page] -> [Page] +fillVariables sheet results pages = [ fillPageVariables appliedVars p | p <- pages | appliedVars <- map applyVariable ([1..] `zip` valueMaps) ] where vars = sheetVariableFields sheet - valueMaps = map makeValueMap results + valueMaps = map makeValueMap + [ MkSheetResult rf nr + | MkSheetResult rf _ <- results + | MkSheetResult _ nr <- newResults + ] docVals = LM.unionsWith (++) valueMaps - results = map (maybe (error "Roundtrip failed!") id . extractPage sheet) pages + newResults = map (maybe (error "1Roundtrip failed!") id . extractPage sheet) pages applyVariable :: (Int, ValueMap) -> LabelMap AppliedVariable applyVariable (pageNum, pageVals) = LM.mapMaybeWithKey applyOneVariable vars where @@ -143,9 +202,13 @@ SDoc -> docVals SPage -> pageVals getVar VPage = formatNumber pageNum - getVar (VSum scope label) = formatDotted $ sum (map parseVal $ valOf scope label) + getVar (VSum scope label) = formatDotted $ sum (map valToInt $ valOf scope label) getVar (VCount scope label) = formatNumber $ length (valOf scope label) - getVar (VLiteral lit) = lit `S.append` S.replicate (len - S.length lit) ' ' + getVar (VLiteral lit) = formatLiteral lit + getVar (VLabel label) = formatLiteral $ case valOf SPage label of + [] -> S.empty + (x:_) -> x + formatLiteral lit = lit `S.append` S.replicate (len - S.length lit) ' ' formatNumber = S.pack . printf ("%" ++ show len ++ "d") formatDotted n = S.pack $ (replicate pad ' ') ++ dottedStr ++ ".00" where @@ -154,10 +217,6 @@ dottedStr = reverse (addDot $ reverse str) addDot (x:y:z:rest@(_:_)) = (x:y:z:',':addDot rest) addDot xs = xs - parseVal :: Value -> Int - parseVal val = case S.readInt (S.filter isDigit (S.takeWhile (/= '.') val)) of - Just (num, _) -> num - _ -> 0 makeValueMap :: SheetResult -> ValueMap makeValueMap MkSheetResult{ resultFields, resultBlocks } = LM.unionsWith (++) (fieldMap:blockMaps) @@ -220,20 +279,27 @@ where origLinePadded | padLength <= 0 = origLine - | otherwise = origLine `S.append` S.replicate padLength ' ' - padLength = S.length origLine - (col + areaLength - 1) + | otherwise = origLine `S.append` S.replicate padLength '-' + padLength = (col + areaLength - 1) - S.length origLine (before, rest) = S.splitAt (col-1) origLinePadded after = S.drop areaLength rest areaLength = S.length areaLine -doResult :: Sheet -> LabelMap [OrderBy Label] -> SheetResult -> ([PageCapacity], FitAttempt) - -> ([PageCapacity], FitAttempt) -doResult MkSheet{ sheetFrames } orders MkSheetResult{ resultBlocks } (pcs, att) = (pc:pcs, att') +doCapacity :: Sheet -> SheetResult -> [PageCapacity] -> [PageCapacity] +doCapacity MkSheet{ sheetFrames } MkSheetResult{ resultBlocks } pcs = pc:pcs where pc = map frameToSlot framesOccured framesOccured = filter (labelOccured . frameBlocks) sheetFrames labelOccured lm = any (`LM.member` lm) resultLabels resultLabels = LM.keys resultBlocks + frameToSlot MkFrame{ frameBox, frameBlocks } = MkSlot + { slotSize = boxBottom frameBox - boxTop frameBox + 1 + , slotBlocks = LM.keys frameBlocks + } + +doAttempt :: LabelMap [OrderBy Label] -> SheetResult -> FitAttempt -> FitAttempt +doAttempt orders MkSheetResult{ resultBlocks } att = att' + where att' = LM.unionsWith mappend [att, LM.mapMaybeWithKey blockToData resultBlocks] blockToData lbl (MkBlockResult lms) = case areas of [] -> Nothing @@ -246,10 +312,6 @@ Just orderBys -> \vals -> map (fmap (`LM.lookup` vals)) orderBys Nothing -> const [] areas = [ (orderFrom vals, area) | (area, vals) <- lms ] - frameToSlot MkFrame{ frameBox, frameBlocks } = MkSlot - { slotSize = boxBottom frameBox - boxTop frameBox + 1 - , slotBlocks = LM.keys frameBlocks - } areaRows :: Area -> Row areaRows (MkPage lns) = length lns @@ -267,7 +329,10 @@ sheetVariableFields MkSheet{ sheetFrames, sheetFields } = LM.unions filteredMaps where filteredMaps = map (LM.filter (isJust . fieldVariable)) fieldMaps - fieldMaps = sheetFields : concatMap frameVariableFields sheetFrames + fieldMaps = LM.mapWithKey addVariable sheetFields : concatMap frameVariableFields sheetFrames + addVariable lbl fld@MkField{ fieldVariable } = case fieldVariable of + Just{} -> fld + _ -> fld{ fieldVariable = Just (VLabel lbl) } frameVariableFields frame@MkFrame{ frameBox } = map blockVariableFields blocks where blocks = LM.elems (frameBlocks frame) diff --git a/src/Text/PageIO/Types.hs b/src/Text/PageIO/Types.hs --- a/src/Text/PageIO/Types.hs +++ b/src/Text/PageIO/Types.hs @@ -1,8 +1,11 @@ +{-# OPTIONS -funbox-strict-fields #-} module Text.PageIO.Types (module Text.PageIO.Types, module Text.PageIO.LabelMap) where import Text.PageIO.LabelMap (LabelMap, Label, toLabel, fromLabel) import Data.ByteString.Internal (inlinePerformIO, memcmp, ByteString(..)) +import Data.Char (isDigit) import Foreign.Ptr import Foreign.ForeignPtr +import qualified Data.ByteString.Char8 as S newtype Page = MkPage { pageLines :: [Value] } deriving (Show, Eq, Ord) @@ -17,28 +20,29 @@ type Value = ByteString data Box = MkBox - { boxLeft :: Col - , boxTop :: Row + { boxLeft :: !Col + , boxTop :: !Row , boxRight :: Col - , boxBottom :: Row + , boxBottom :: !Row } deriving (Show, Eq, Ord) data Sheet = MkSheet - { sheetBox :: Box - , sheetPatterns :: LabelMap Pattern - , sheetFields :: LabelMap Field - , sheetFrames :: [Frame] - , sheetGroupBy :: [Label] + { sheetName :: !Label + , sheetBox :: !Box + , sheetPatterns :: !(LabelMap Pattern) + , sheetFields :: !(LabelMap Field) + , sheetFrames :: ![Frame] + , sheetGroupBy :: ![Label] -- , sheetPositioning :: CharPos | GridPos -- , sheetUseBlockSortPriority :: Bool } deriving (Show, Eq, Ord) data Pattern = MkPattern - { patternBox :: Box - , patternMatch :: Match - , patternUseWildcards :: Bool + { patternBox :: !Box + , patternMatch :: !Match + , patternUseWildcards :: !Bool } deriving (Show, Eq, Ord) @@ -47,36 +51,37 @@ data Variable = VPage - | VSum{ vScope :: Scope, vLabel :: Label } - | VCount{ vScope :: Scope, vLabel :: Label } - | VLiteral{ vValue :: Value } + | VSum{ vScope :: !Scope, vLabel :: !Label } + | VCount{ vScope :: !Scope, vLabel :: !Label } + | VLabel{ vLabel :: !Label } + | VLiteral{ vValue :: !Value } deriving (Show, Eq, Ord) data Field = MkField - { fieldBox :: Box - , fieldVariable :: Maybe Variable - , fieldKeepSpaces :: Bool - , fieldFormat :: FieldFormat + { fieldBox :: !Box + , fieldVariable :: !(Maybe Variable) + , fieldKeepSpaces :: !Bool + , fieldFormat :: !FieldFormat } deriving (Show, Eq, Ord) data Frame = MkFrame - { frameBox :: Box - , frameBlocks :: LabelMap Block + { frameBox :: !Box + , frameBlocks :: !(LabelMap Block) } deriving (Show, Eq, Ord) -data Operator = ONot Operator | OContains | OEq | OEndsWith | OStartsWith +data Operator = ONot !Operator | OContains | OEq | OEndsWith | OStartsWith deriving (Show, Eq, Ord) data Filter = MkFilter - { filterField :: Label - , filterOperator :: Operator - , filterMatch :: Match + { filterField :: !Label + , filterOperator :: !Operator + , filterMatch :: !Match } deriving (Show, Eq, Ord) -data OrderBy a = DAscending a | DDescending a +data OrderBy a = DAscending !a | DDescending !a deriving (Show, Eq) instance Functor OrderBy where @@ -90,11 +95,11 @@ compare _ _ = GT data Block = MkBlock - { blockLines :: Row - , blockPatterns :: LabelMap Pattern - , blockFields :: LabelMap Field - , blockOrderBy :: [OrderBy Label] - , blockFilterBy :: [Filter] + { blockLines :: !Row + , blockPatterns :: !(LabelMap Pattern) + , blockFields :: !(LabelMap Field) + , blockOrderBy :: ![OrderBy Label] + , blockFilterBy :: ![Filter] -- , blockRule :: Rule -- , blockSortPriority :: Priority } @@ -118,3 +123,12 @@ rv <- memcmp matchPtr (valuePtr `plusPtr` n) sz if rv == 0 then return True else go (n+1) in go 0 + +valToIntVal :: Value -> Value +valToIntVal = S.filter isDigit . S.takeWhile (/= '.') + +valToInt :: Value -> Int +valToInt val = case S.readInt (valToIntVal val) of + Just (num, _) -> num + _ -> 0 +