PageIO 0.0.1 → 0.0.2

raw patch · 7 files changed

+212/−98 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• PageIO.cabal +2/−1
• src/Text/PageIO/Extract.hs +15/−4
• src/Text/PageIO/LabelMap.hs +8/−0
• src/Text/PageIO/Parser.hs +20/−6
• src/Text/PageIO/Run.hs +2/−1
• src/Text/PageIO/Transform.hs +121/−56
• src/Text/PageIO/Types.hs +44/−30

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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+