PageIO (empty) → 0.0.1
raw patch · 11 files changed
+1009/−0 lines, 11 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, iconv, parsec, stringtable-atom
Files
- LICENSE +18/−0
- PageIO.cabal +23/−0
- README +7/−0
- Setup.lhs +3/−0
- src/Text/PageIO.hs +10/−0
- src/Text/PageIO/Extract.hs +111/−0
- src/Text/PageIO/LabelMap.hs +74/−0
- src/Text/PageIO/Parser.hs +266/−0
- src/Text/PageIO/Run.hs +52/−0
- src/Text/PageIO/Transform.hs +325/−0
- src/Text/PageIO/Types.hs +120/−0
+ LICENSE view
@@ -0,0 +1,18 @@+Copyright 2008 by Audrey Tang++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to+deal in the Software without restriction, including without limitation the+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+sell copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:+ +The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.+ +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ PageIO.cabal view
@@ -0,0 +1,23 @@+name: PageIO+version: 0.0.1+copyright: 2008 Audrey Tang+license: BSD3+license-file: LICENSE+author: Audrey Tang <audreyt@audreyt.org>+maintainer: Audrey Tang <audreyt@audreyt.org>+synopsis: Page-oriented extraction and composition library+description: Provides an interface to the PageIn export format (.dux)+ from the StreamServe Persuasion(tm) platform, using it+ both as a data extraction as well as a page layout DSL.+ (Extremely experimental, no documentations at the moment!)+stability: experimental+build-type: Simple+extensions: GeneralizedNewtypeDeriving, RecordPuns, ParallelListComp, PatternGuards+exposed-modules: Text.PageIO+ Text.PageIO.Extract Text.PageIO.LabelMap+ Text.PageIO.Parser Text.PageIO.Run+ Text.PageIO.Transform Text.PageIO.Types +build-depends: base, array, bytestring, parsec >= 3.0, containers, stringtable-atom, iconv+extra-source-files: README+hs-source-dirs: src+category: Text
+ README view
@@ -0,0 +1,7 @@+This library provides an interface to the PageIn export format (.dux) from+the StreamServe Persuasion(tm) platform, using it both as a data extraction+as well as a page layout DSL.++At the moment it's extremely experimental, with no documentations and+no examples, and as a whole may not make any sense except for existing+users of StreamServe. :-)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Text/PageIO.hs view
@@ -0,0 +1,10 @@+module Text.PageIO+ ( module Text.PageIO.Run+ , module Text.PageIO.Parser+ , module Text.PageIO.Transform+ , module Text.PageIO.Extract+ ) where+import Text.PageIO.Run+import Text.PageIO.Parser+import Text.PageIO.Transform+import Text.PageIO.Extract
+ src/Text/PageIO/Extract.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, RecordPuns #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++module Text.PageIO.Extract where+import Data.Maybe+import Data.Monoid+import Text.PageIO.Types+import qualified Text.PageIO.LabelMap as LM+import qualified Data.ByteString.Char8 as S++type Area = Page+newtype BlockResult = MkBlockResult { blockResults :: [(Area, LabelMap Value)] }+ deriving (Eq, Ord, Monoid)++data SheetResult = MkSheetResult+ { resultFields :: LabelMap Value+ , resultBlocks :: LabelMap BlockResult+ }+ deriving (Eq, Ord)++instance Show BlockResult where+ show (MkBlockResult []) = "[]"+ show (MkBlockResult rs) = concatMap prettyBlockResult rs+ where+ prettyBlockResult (_, lm) = case LM.toList lm of+ [] -> "\n - {}"+ (v:vs) -> "\n - " ++ prettyEntry v ++ concatMap ((" " ++) . prettyEntry) vs++instance Show SheetResult where+ show (MkSheetResult fs bs) = concat+ [ "---\n"+ , concatMap prettyEntry (LM.toList fs)+ , concatMap prettyEntry (LM.toList bs)+ ]++prettyEntry :: Show a => (Label, a) -> String+prettyEntry (lbl, val) = do+ show lbl ++ ": " ++ show val ++ "\n"+++extractPage :: Sheet -> Page -> Maybe SheetResult+extractPage MkSheet{sheetBox, sheetFields, sheetPatterns, sheetFrames} page+ | and patternResults = Just $ MkSheetResult+ { resultFields = fieldResults+ , resultBlocks = frameResults+ }+ | otherwise = Nothing+ where+ sheetArea = crop sheetBox page+ patternResults = map (checkPattern sheetArea) (LM.elems sheetPatterns)+ fieldResults = fmap (extractField sheetArea) sheetFields+ frameResults = LM.unionsWith mappend (map extractFrame sheetFrames)+ extractFrame MkFrame{ frameBox, frameBlocks } = LM.fromListWith mappend blockResults+ where+ frameArea = crop frameBox sheetArea+ blockResults = extractBlocks frameBlocks frameArea++crop :: Box -> Page -> Page+crop MkBox{boxTop, boxBottom, boxLeft, boxRight} (MkPage lns) = MkPage (map doCol (doRows lns))+ where+ doRows = take (boxBottom - boxTop + 1) . drop (boxTop - 1)+ doCol = S.take (boxRight - boxLeft + 1) . S.drop (boxLeft - 1)++checkPattern :: Page -> Pattern -> Bool+checkPattern page MkPattern{ patternBox, patternMatch }+ | val `matches` patternMatch = True+ | otherwise = False+ where+ val = pageVal $ crop patternBox page++extractField :: Page -> Field -> Value+extractField page MkField{ fieldBox } = pageVal $ crop fieldBox page++extractBlocks :: LabelMap Block -> Page -> [(Label, BlockResult)]+extractBlocks blocks page@(MkPage lns) = case blockResults of+ [] -> case lns of+ (_:rest) -> extractBlocks blocks (MkPage rest)+ _ -> mempty+ ((skip, res):_) -> res:extractBlocks blocks (MkPage $ drop skip lns)+ where+ blockResults =+ [ (blockLines b, (lbl, fromJust es))+ | (lbl, b) <- LM.toList blocks+ , let es = extractBlock b page, isJust es+ ]++extractBlock :: Block -> Page -> Maybe BlockResult+extractBlock MkBlock{ blockLines, blockPatterns, blockFields, blockFilterBy } page@(MkPage lns)+ | length blockArea < blockLines = Nothing+ | and patternResults = Just . MkBlockResult $ if filtersPass+ then [(MkPage blockArea, fieldResults)]+ else []+ | otherwise = Nothing+ where+ blockArea = take blockLines lns+ patternResults = map (checkPattern page) (LM.elems blockPatterns)+ fieldResults = fmap (extractField page) blockFields+ filtersPass = all runFilter blockFilterBy+ runFilter (flt@MkFilter{ filterField, filterOperator, filterMatch })+ = case LM.lookup filterField fieldResults of+ Just val -> case filterOperator of+ ONot op -> not $ runFilter flt{ filterOperator = op }+ OContains -> val `matches` filterMatch+ OStartsWith -> matchValue filterMatch `S.isPrefixOf` val + OEndsWith -> matchValue filterMatch `S.isSuffixOf` val + OEq -> matchValue filterMatch == val+ _ -> False++pageVal :: Page -> Value+pageVal (MkPage page) = S.concat page+
+ src/Text/PageIO/LabelMap.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Text.PageIO.LabelMap where++import StringTable.Atom+import qualified Data.IntMap as IM+import Data.Monoid++newtype LabelMap a = MkLabelMap { labelMap :: IM.IntMap a }+ deriving (Eq, Ord, Functor, Monoid)++newtype Label = MkLabel { labelAtom :: Atom }+ deriving (Eq, Ord)++instance Show a => Show (LabelMap a) where+ show = show . toList++instance Show Label where+ show = fromLabel++toLabel :: ToAtom a => a -> Label+toLabel = MkLabel . toAtom++fromLabel :: FromAtom a => Label -> a+fromLabel = fromAtom . labelAtom++fromList :: [(Label, a)] -> LabelMap a+fromList ps = MkLabelMap $ IM.fromList [ (fromLabel l, x) | (l, x) <- ps ]++fromListWith :: (a -> a -> a) -> [(Label, a)] -> LabelMap a+fromListWith f ps = MkLabelMap $ IM.fromListWith f [ (fromLabel l, x) | (l, x) <- ps ]++toList :: LabelMap a -> [(Label, a)]+toList lm = [ (keyToLabel l, x) | (l, x) <- IM.toList $ labelMap lm ]++{-# INLINE keyToLabel #-}+keyToLabel :: IM.Key -> Label+keyToLabel = MkLabel . unsafeIntToAtom++mapWithKey :: (Label -> a -> b) -> LabelMap a -> LabelMap b+mapWithKey f lm = MkLabelMap $ IM.mapWithKey (f . keyToLabel) (labelMap lm)++elems :: LabelMap a -> [a]+elems = IM.elems . labelMap++unions :: [LabelMap a] -> LabelMap a+unions = MkLabelMap . IM.unions . Prelude.map labelMap++unionsWith :: (a -> a -> a) -> [LabelMap a] -> LabelMap a+unionsWith f = MkLabelMap . IM.unionsWith f . Prelude.map labelMap++lookup :: Label -> LabelMap a -> Maybe a+lookup l = IM.lookup (fromLabel l) . labelMap++insert :: Label -> a -> LabelMap a -> LabelMap a+insert l v = MkLabelMap . IM.insert (fromLabel l) v . labelMap++insertWith :: (a -> a -> a) -> Label -> a -> LabelMap a -> LabelMap a+insertWith f l v = MkLabelMap . IM.insertWith f (fromLabel l) v . labelMap++member :: Label -> LabelMap a -> Bool+member l = IM.member (fromLabel l) . labelMap++keys :: LabelMap a -> [Label]+keys = Prelude.map keyToLabel . IM.keys . labelMap++filter :: (a -> Bool) -> LabelMap a -> LabelMap a+filter f = MkLabelMap . IM.filter f . labelMap++mapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b+mapMaybe f = MkLabelMap . IM.mapMaybe f . labelMap++mapMaybeWithKey :: (Label -> a -> Maybe b) -> LabelMap a -> LabelMap b+mapMaybeWithKey f = MkLabelMap . IM.mapMaybeWithKey (f . keyToLabel) . labelMap+
+ src/Text/PageIO/Parser.hs view
@@ -0,0 +1,266 @@+module Text.PageIO.Parser where++import Text.Parsec+import Text.Parsec.ByteString+import Data.ByteString.Lazy.Char8 (pack, ByteString, toChunks)+import Text.PageIO.Types+import Control.Monad (liftM3, liftM4)+import Numeric (readDec)+import Codec.Text.IConv+import qualified Data.ByteString.Char8 as S+import qualified Text.PageIO.LabelMap as LM++readSheet :: String -> IO (Either ParseError Sheet)+readSheet = parseFromFile sheet++parseMaybe :: Parser a -> Parser (Maybe a)+parseMaybe r = fmap Just r <|> return Nothing++maybeFieldVariable :: Parser (Maybe Variable)+maybeFieldVariable = parseMaybe $ do+ char '$'+ choice+ [ sym "PAGE" >> return VPage+ , literalVariable+ , functionVariable+ ]++literalVariable :: Parser Variable+literalVariable = do+ s <- literalStr+ ret $ VLiteral s++functionVariable :: Parser Variable+functionVariable = do+ fun <- choice+ [ sym "SUM(" >> return VSum+ , sym "COUNT(" >> return VCount+ ]+ scope <- choice+ [ sym "page." >> return SPage+ , sym "doc." >> return SDoc+ , return SPage+ ]+ fld <- many1 $ noneOf ".) "+ sym ")"+ return $ fun scope (toLabel fld)++maybeFieldFormat :: Parser (Maybe FieldFormat)+maybeFieldFormat = parseMaybe $ do + sym "Format"+ choice+ [ sym "\"NZ ZZZ ZZ9,99\"" >> return (FNumeric 0)+ , sym "\"Nk= d=.\"" >> return (FNumeric 0)+ , sym "\"NZ,ZZZ,ZZZ,ZZ#.##\"" >> return (FNumeric 2)+ ]++maybeFilters :: Parser (Maybe [Filter])+maybeFilters = parseMaybe $ do+ sym "WHERE"+ parseFilter `sepEndBy` sym "AND"++parseFilter :: Parser Filter+parseFilter = liftM3 MkFilter parseLabel operator (fmap mkMatch quotedValue)++operator :: Parser Operator+operator = choice+ [ sym "NOT" >> fmap ONot operator+ , sym "CONTAINS" >> return OContains+ , sym "STARTSWITH" >> return OStartsWith+ , sym "ENDSWITH" >> return OEndsWith+ , sym "==" >> return OEq+ , sym "=" >> return OEq+ , sym "!=" >> return (ONot OEq)+ , sym "<>" >> return (ONot OEq)+ ]++maybeOrderBys :: Parser (Maybe [OrderBy Label])+maybeOrderBys = parseMaybe $ do+ sym "ORDER"+ sym "BY"+ orders <- (`sepEndBy` sym ",") $ do+ lbl <- parseLabel+ choice+ [ sym "DESC" >> return (DDescending lbl)+ , optional (sym "ASC") >> return (DAscending lbl)+ ]+ ret $ orders++maybeBy :: String -> Parser (Maybe [Label])+maybeBy by = parseMaybe $ do+ sym by+ sym "BY"+ lbls <- parseLabel `sepEndBy` sym ","+ ret $ lbls++maybeRule :: Parser (Maybe a) -> Parser (Maybe a)+maybeRule p = (<|> return Nothing) $ do+ between (sym "Rule" >> sym "\"") (sym "\";") p++parseLabel :: Parser Label+parseLabel = do+ s <- many (noneOf "\", ") + ret $ toLabel s++sheet :: Parser Sheet+sheet = do+ manyTill anyChar (sym "UseCharPos" <|> sym "UseGridPos")+ sym "Sheet"+ right <- num+ bottom <- num+ optional (sym "UsePriority")+ pats <- many pattern+ grp <- maybeRule $ maybeBy "GROUP"+ flds <- many field+ frames <- many frame+ sym "End"+ ret $ MkSheet+ { sheetBox = MkBox+ { boxLeft = 1+ , boxTop = 1+ , boxRight = right+ , boxBottom = bottom+ }+ , sheetPatterns = LM.fromList+ [ (lbl, pat{ patternBox = box{ boxRight = right } })+ | (lbl, pat) <- pats, let box = patternBox pat+ ]+ , sheetFields = LM.fromList flds+ , sheetFrames = (`fmap` frames) $ \frm -> frm+ { frameBlocks = (`fmap` frameBlocks frm) $ \blk -> blk+ { blockPatterns = (`fmap` blockPatterns blk) $ \pat -> pat+ { patternBox = (patternBox pat){ boxRight = right }+ }+ }+ }+ , sheetGroupBy = maybe [] id grp+ }++sym :: String -> Parser ()+sym s = try (string s) >> sp++ret :: a -> Parser a+ret x = sp >> return x++sp :: Parser ()+sp = skipMany (space <|> (try (string "//") >> skipMany (noneOf ['\n']) >> anyChar))++num :: Parser Int+num = do+ digits <- many1 digit+ ret $ fst (head $ readDec digits)++pattern :: Parser (Label, Pattern)+pattern = do+ sym "Match"+ lbl <- labelStr+ left <- num+ top <- num+ mat <- matchStr+ wc <- (sym "UseWildCards" >> return True) <|> return False+ retLabel lbl MkPattern+ { patternBox = MkBox+ { boxLeft = left+ , boxTop = top+ , boxRight = error "To be updated later"+ , boxBottom = top+ }+ , patternMatch = mat+ , patternUseWildcards = wc+ }++field :: Parser (Label, Field)+field = do+ sym "Field"+ lbl <- labelStr+ box <- boxNumbers+ var <- maybeFieldVariable+ fmt <- maybeFieldFormat+ char ';'+ retLabel lbl MkField+ { fieldBox = box+ , fieldKeepSpaces = True+ , fieldVariable = var+ , fieldFormat = maybe FGeneral id fmt+ }++boxNumbers :: Parser Box+boxNumbers = liftM4 MkBox num num num num++frame :: Parser Frame+frame = do+ sym "Frame"+ box <- boxNumbers+ blocks <- many block+ sym "End"+ ret $ MkFrame+ { frameBox = box+ , frameBlocks = LM.fromList blocks+ }++retLabel :: Label -> a -> Parser (Label, a)+retLabel l x = ret (l, x)++block :: Parser (Label, Block)+block = do+ sym "Block"+ lbl <- labelStr+ optional (sym "UsePriority")+ sym "Lines"+ lns <- num+ pats <- many pattern+ (filters, orders) <- fmap (maybe (Nothing, Nothing) id) . maybeRule $ do+ filters <- maybeFilters+ orders <- maybeOrderBys+ return (Just (filters, orders))+ flds <- many field+ sym "End"+ retLabel lbl MkBlock+ { blockLines = lns+ , blockPatterns = LM.fromList+ [ (l, pat{ patternBox = adjustBox box })+ | (l, pat) <- pats, let box = patternBox pat+ ]+ , blockFields = LM.fromList+ [ (l, fld{ fieldBox = adjustBox box })+ | (l, fld) <- flds, let box = fieldBox fld+ ]+ , blockOrderBy = maybe [] id orders+ , blockFilterBy = maybe [] id filters+ }+ where+ -- We adjust box because StreamServe counts in-block coordinates from (0,0).+ adjustBox (MkBox l t r b) = MkBox (l+1) (t+1) (r+1) (b+1)++literalStr :: Parser Value +literalStr = do+ beginQuote <- oneOf "\"'"+ s <- many (noneOf [beginQuote])+ char beginQuote+ ret . packLBS . convert "UTF-8" "CP950" $ pack s++matchStr :: Parser Match+matchStr = fmap (mkMatch . packLBS . convert "UTF-8" "CP950") str++mkMatch :: Value -> Match+mkMatch s = MkMatch $ S.init (s `S.append` S.singleton '\0')++packLBS :: ByteString -> S.ByteString+packLBS = S.concat . toChunks++labelStr :: Parser Label+labelStr = fmap (toLabel . packLBS) str++str :: Parser ByteString+str = do+ char '"'+ s <- many (noneOf ['"'])+ char '"'+ ret $ pack s++quotedValue :: Parser Value+quotedValue = do+ beginQuote <- oneOf "\"'"+ s <- many (noneOf [beginQuote])+ char beginQuote+ ret $ S.pack s
+ src/Text/PageIO/Run.hs view
@@ -0,0 +1,52 @@+module Text.PageIO.Run where+import Data.Maybe+import Text.PageIO.Types+import System.IO+import Data.ByteString.Unsafe+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++readPages :: FilePath -> IO [Page]+readPages fn = openBinaryFile fn ReadMode >>= hReadPages++hReadPages :: Handle -> IO [Page]+hReadPages fh = do+ hSetBinaryMode fh True+ sz <- hFileSize fh+ -- Cutoff is 64MB; we map the data directly to memory if it's less than that amount+ if sz > 64 * 1024 * 1024+ then hReadPagesLazy fh+ else hReadPagesStrict fh (fromEnum sz)++hReadPagesLazy :: Handle -> IO [Page]+hReadPagesLazy fh = do+ hSetBuffering fh (BlockBuffering (Just defaultChunkSize))+ content <- L.hGetContents fh+ return $ case map (S.concat . L.toChunks) (L.split '\x0C' content) of+ [] -> []+ (hd:tl) -> map (MkPage . map dropCR . S.lines) (hd:map (S.tail . S.dropWhile (/= '\n')) tl)+ where+ dropCR x+ | S.null x = S.copy x+ | S.last x == '\r' = S.copy (S.init x)+ | otherwise = S.copy x++hReadPagesStrict :: Handle -> Int -> IO [Page]+hReadPagesStrict fh sz = do+ hSetBuffering fh (BlockBuffering (Just sz))+ content <- S.hGet fh sz+ 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)+ length (pageLines $ last pages) `seq` unsafeFinalize content+ return pages+ where+ dropCR x+ | S.null x = S.copy x+ | S.last x == '\r' = S.copy (S.init x)+ | otherwise = S.copy x++putPage :: Page -> IO ()+putPage = mapM_ S.putStrLn . pageLines
+ src/Text/PageIO/Transform.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE RecordPuns, ParallelListComp, PatternGuards #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++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 Text.Printf+import qualified Text.PageIO.LabelMap as LM+import qualified Data.ByteString.Char8 as S++import Text.PageIO.Types+import Text.PageIO.Extract (extractPage, SheetResult(..), BlockResult(..), Area)++type Doc = [Page]++type ValueMap = LabelMap [Value]+data AppliedVariable = MkAppliedVariable+ { avRow :: Row+ , avCol :: Col+ , avValue :: Value+ }+ deriving (Show, Eq, Ord)++data Slot = MkSlot+ { slotSize :: Row+ , slotBlocks :: [Label]+ }+ deriving (Eq, Ord, Show)++type Ordered a = ([OrderBy (Maybe Value)], a)++data BlockData = MkBlockData+ { dataSize :: Row+ , dataAreas :: [Ordered Area]+ }+ deriving (Eq, Ord, Show)++instance Monoid BlockData where+ mempty = MkBlockData (error "impossible") []+ mappend x y = x{ dataAreas = dataAreas x ++ dataAreas y }+ mconcat [] = mempty+ mconcat xs = MkBlockData+ { dataSize = dataSize (head xs)+ , dataAreas = concatMap dataAreas xs+ }++type PageCapacity = [Slot]+type FitAttempt = LabelMap BlockData++-- 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+ where+ docGroups = case sheetGroupBy sheet of+ [] -> [resultAndPages]+ lbls -> groupBy ((==) `on` docKeys) resultAndPages+ where+ docKeys (res, _) = map (`LM.lookup` resultFields res) lbls+ resultAndPages = + [ (res, page)+ | Just res <- map (extractPage sheet) pages+ | page <- pages+ ]++-- Using Sheet+Page as template to rewrite a page+-- First, rewrite SheetResult to eliminate all Variable fields+-- Next, populate all fields+-- Finally, populate frames with blocks and space-ify the rest of the frame lines+--+-- First try fitting everything on the last page.+-- All frames must be consumed by blocks mentioned on that page.+-- If it won't fit, then retry with the last two pages, etc.+--+-- Oh, and we re-extract the result pages to fill in vars! What joy!+--+-- 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+ | 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 + capacityTails = repeatTails capacity+ pageTails = repeatTails pages+ pageBindings = + [ (tryFit pc sortedAttempt, pages)+ | pc <- capacityTails+ | pages <- pageTails+ ]+ sortedAttempt = fmap (\dat -> dat{ dataAreas = sortBy (compare `on` fst) $ dataAreas dat }) attempt++-- Given "abc", generate ["", "c", "bc", "abc", "aabc", "aaabc", "aaaabc"...]+repeatTails :: [a] -> [[a]]+repeatTails [] = []+repeatTails orig@(x:xs) = reverse (tails xs) ++ map (++ orig) infinitePrefixes+ where+ infinitePrefixes = inits (repeat x)++-- We now calculate the applied vars for each page+fillVariables :: Sheet -> Doc -> Doc+fillVariables sheet pages =+ [ fillPageVariables appliedVars p+ | p <- pages+ | appliedVars <- map applyVariable ([1..] `zip` valueMaps)+ ]+ where+ vars = sheetVariableFields sheet+ valueMaps = map makeValueMap results+ docVals = LM.unionsWith (++) valueMaps+ results = map (maybe (error "Roundtrip failed!") id . extractPage sheet) pages+ applyVariable :: (Int, ValueMap) -> LabelMap AppliedVariable+ applyVariable (pageNum, pageVals) = LM.mapMaybeWithKey applyOneVariable vars+ where+ applyOneVariable :: Label -> Field -> Maybe AppliedVariable+ applyOneVariable lbl MkField{ fieldBox, fieldVariable }+ | Just var <- fieldVariable+ , LM.member lbl pageVals = Just MkAppliedVariable+ { avRow = boxTop fieldBox+ , avCol = boxLeft fieldBox+ , avValue = getVar var+ }+ | otherwise = Nothing+ where+ len = boxRight fieldBox - boxLeft fieldBox + 1+ valOf :: Scope -> Label -> [Value]+ valOf scope lbl = maybe [] id $ LM.lookup lbl vals+ where+ vals = case scope of+ SDoc -> docVals+ SPage -> pageVals+ getVar VPage = formatNumber pageNum+ getVar (VSum scope label) = formatDotted $ sum (map parseVal $ valOf scope label)+ getVar (VCount scope label) = formatNumber $ length (valOf scope label)+ getVar (VLiteral 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+ pad = len - length dottedStr - 3+ str = show n+ 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)+ where+ fieldMap = fmap (:[]) resultFields+ blockMaps :: [ValueMap]+ blockMaps = map makeBlockValueMap $ LM.elems resultBlocks+ makeBlockValueMap :: BlockResult -> ValueMap+ makeBlockValueMap (MkBlockResult avs) = LM.unionsWith (++) maps+ where+ maps :: [LabelMap [Value]]+ maps = map (fmap (:[]) . snd) avs++-- Now comes the fun part.+-- For each frame, see if any of its blocks are there.+-- If yes, concat them and pain the rest white.+makePage :: Sheet -> PageBinding -> Page -> Page+makePage MkSheet{ sheetFrames } binding page = foldl makeFrame page sheetFrames+ where+ makeFrame page MkFrame{ frameBox, frameBlocks }+ | null frameBindings = page+ | otherwise = pageReplaced+ where+ pageCleared = clearArea frameBox page+ pageReplaced = replaceArea frameBox (concat frameBindings) pageCleared+ frameBindings = + [ fromJust result+ | frameLabel <- LM.keys frameBlocks+ , let result = LM.lookup frameLabel binding+ , isJust result+ ]++-- Start with +replaceArea :: Box -> [Area] -> Page -> Page+replaceArea _ [] page = page+replaceArea box@MkBox{ boxTop, boxLeft } (area:rest) page = replaceArea box' rest page'+ where+ box' = box{ boxTop = boxTop + areaRows area}+ page' = fillArea boxTop boxLeft area page++clearArea :: Box -> Page -> Page+clearArea MkBox{ boxTop, boxLeft, boxBottom, boxRight } (MkPage lns) = MkPage $ before ++ cleared ++ after+ where+ (before, rest) = splitAt (boxTop-1) lns+ (middle, after) = splitAt (boxBottom-boxTop+1) rest+ cleared = map (fillLine boxLeft . ((,) whiteSpace)) middle+ whiteSpace = S.replicate (boxRight-boxLeft+1) ' '++{-# INLINE fillArea #-}+fillArea :: Row -> Col -> Area -> Page -> Page+fillArea row col (MkPage areaLines) (MkPage lns) = MkPage $ before ++ replaced ++ after+ where+ (before, rest) = splitAt (row-1) lns+ (middle, after) = splitAt (length areaLines) rest+ replaced = map (fillLine col) (areaLines `zip` middle)++{-# INLINE fillLine #-}+fillLine :: Col -> (Value, Value) -> Value+fillLine col (areaLine, origLine) = S.concat [before, areaLine, after]+ where+ origLinePadded+ | padLength <= 0 = origLine+ | otherwise = origLine `S.append` S.replicate padLength ' ' + padLength = S.length origLine - (col + areaLength - 1)+ (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')+ where+ pc = map frameToSlot framesOccured+ framesOccured = filter (labelOccured . frameBlocks) sheetFrames+ labelOccured lm = any (`LM.member` lm) resultLabels+ resultLabels = LM.keys resultBlocks+ att' = LM.unionsWith mappend [att, LM.mapMaybeWithKey blockToData resultBlocks]+ blockToData lbl (MkBlockResult lms) = case areas of + [] -> Nothing+ ((_, area):_) -> Just MkBlockData+ { dataSize = areaRows area+ , dataAreas = areas+ }+ where+ orderFrom = case LM.lookup lbl orders of+ 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++fillPageVariables :: LabelMap AppliedVariable -> Page -> Page+fillPageVariables avs page = foldl fillOneVar page (LM.elems avs)+ where+ fillOneVar page MkAppliedVariable{ avRow, avCol, avValue }+ = fillArea avRow avCol (valueToArea avValue) page++valueToArea :: Value -> Area+valueToArea val = MkPage [val]++sheetVariableFields :: Sheet -> LabelMap Field+sheetVariableFields MkSheet{ sheetFrames, sheetFields } = LM.unions filteredMaps+ where+ filteredMaps = map (LM.filter (isJust . fieldVariable)) fieldMaps+ fieldMaps = sheetFields : concatMap frameVariableFields sheetFrames+ frameVariableFields frame@MkFrame{ frameBox } = map blockVariableFields blocks+ where+ blocks = LM.elems (frameBlocks frame)+ rowOffset = boxTop frameBox - 1+ colOffset = boxLeft frameBox - 1+ blockVariableFields = fmap adjustField . blockFields+ adjustField field@MkField{ fieldBox = MkBox{ boxTop, boxLeft, boxBottom, boxRight } } = field+ { fieldBox = MkBox+ { boxTop = boxTop + rowOffset+ , boxLeft = boxLeft + colOffset+ , boxBottom = boxBottom + rowOffset+ , boxRight = boxRight + colOffset+ }+ }++sheetBlockOrderBys :: Sheet -> LabelMap [OrderBy Label]+sheetBlockOrderBys MkSheet{ sheetFrames } = LM.unions (map frameBlockOrderBys sheetFrames)+ where+ frameBlockOrderBys MkFrame{ frameBlocks } = LM.fromList+ [ (lbl, order) | (lbl, order@(_:_)) <- LM.toList (fmap blockOrderBy frameBlocks) ]++-- Each try is on a list of Frame Capacities+-- Each frame capacity is a number of rows, and the label of blocks it can consume+-- We try it with the total number of blocks++tryFit :: [PageCapacity] -> FitAttempt -> Maybe [PageBinding]+tryFit pcs att = go pcs ([], att)+ where+ go [] (bindings, att)+ | all (null . dataAreas) (LM.elems att) = Just (reverse bindings)+ | otherwise = Nothing+ go (p:ps) (bindings, att) = go ps ((bnd:bindings), att')+ where+ (bnd, att') = fitOnePage p (mempty, att)++fitOnePage :: [Slot] -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)+fitOnePage [] x = x+fitOnePage (s:ss) x = fitOnePage ss $ fitOneSlot s x++fitOneSlot :: Slot -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)+fitOneSlot slot@MkSlot{ slotSize, slotBlocks } x@(binding, att) = case slotBlocks of+ [] -> x+ (b:bs) -> case LM.lookup b att of+ Just dat@MkBlockData{ dataSize, dataAreas } ->+ let consumed = min (length dataAreas) (slotSize `div` dataSize)+ consumedSize = consumed * dataSize+ newData = dat{ dataAreas = drop consumed dataAreas }+ newAttempt = LM.insert b newData att+ newBinding = LM.insertWith (++) b (map snd $ take consumed dataAreas) binding+ newSlot = slot+ { slotSize = slotSize - consumedSize+ , slotBlocks = bs+ }+ in fitOneSlot newSlot (newBinding, newAttempt)+ _ -> fitOneSlot slot{ slotBlocks = bs } x
+ src/Text/PageIO/Types.hs view
@@ -0,0 +1,120 @@+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 Foreign.Ptr+import Foreign.ForeignPtr++newtype Page = MkPage { pageLines :: [Value] }+ deriving (Show, Eq, Ord)++type Col = Int+type Row = Int+type FractionDigits = Int++data FieldFormat = FGeneral | FNumeric FractionDigits | FDate+ deriving (Show, Eq, Ord)++type Value = ByteString++data Box = MkBox+ { boxLeft :: Col+ , boxTop :: Row+ , boxRight :: Col+ , boxBottom :: Row+ }+ deriving (Show, Eq, Ord)++data Sheet = MkSheet+ { 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+ }+ deriving (Show, Eq, Ord)++data Scope = SPage | SDoc+ deriving (Show, Eq, Ord)++data Variable+ = VPage+ | VSum{ vScope :: Scope, vLabel :: Label }+ | VCount{ vScope :: Scope, vLabel :: Label }+ | VLiteral{ vValue :: Value }+ deriving (Show, Eq, Ord)++data Field = MkField+ { fieldBox :: Box+ , fieldVariable :: Maybe Variable+ , fieldKeepSpaces :: Bool+ , fieldFormat :: FieldFormat+ }+ deriving (Show, Eq, Ord)++data Frame = MkFrame+ { frameBox :: Box+ , frameBlocks :: LabelMap Block+ }+ deriving (Show, Eq, Ord)++data Operator = ONot Operator | OContains | OEq | OEndsWith | OStartsWith+ deriving (Show, Eq, Ord)++data Filter = MkFilter+ { filterField :: Label+ , filterOperator :: Operator+ , filterMatch :: Match+ }+ deriving (Show, Eq, Ord)++data OrderBy a = DAscending a | DDescending a+ deriving (Show, Eq)++instance Functor OrderBy where+ fmap f (DAscending x) = DAscending (f x)+ fmap f (DDescending x) = DDescending (f x)++instance Ord a => Ord (OrderBy a) where+ compare (DAscending x) (DAscending y) = compare x y+ compare (DDescending x) (DDescending y) = compare y x+ compare DAscending{} _ = LT+ compare _ _ = GT++data Block = MkBlock+ { blockLines :: Row+ , blockPatterns :: LabelMap Pattern+ , blockFields :: LabelMap Field+ , blockOrderBy :: [OrderBy Label]+ , blockFilterBy :: [Filter]+-- , blockRule :: Rule+-- , blockSortPriority :: Priority+ }+ deriving (Show, Eq, Ord)++newtype Match = MkMatch { matchValue :: Value }+ deriving (Show, Eq, Ord)++{-# INLINE matches #-}+matches :: Value -> Match -> Bool+matches (PS x1 s1 l1) (MkMatch (PS x2 s2 l2))+ | l2 > l1 = False+ | otherwise = inlinePerformIO $+ withForeignPtr x1 $ \p1 ->+ withForeignPtr x2 $ \p2 -> do+ let valuePtr = p1 `plusPtr` s1+ matchPtr = p2 `plusPtr` s2+ sz = fromIntegral l2+ maxOffset = l1 - l2+ go n = if n > maxOffset then return False else do+ rv <- memcmp matchPtr (valuePtr `plusPtr` n) sz+ if rv == 0 then return True else go (n+1)+ in go 0