PageIO 0.0.2 → 0.0.3

raw patch · 11 files changed

+1074/−241 lines, 11 filesdep +attoparsecdep +base64-stringdep +directorydep −parsecsetup-changednew-component:exe:pioPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, base64-string, directory, network, old-time, regex-base, regex-compat, regex-tdfa, sqlite, utf8-string, uuid

Dependencies removed: parsec

API changes (from Hackage documentation)

Files

• PageIO.cabal +16/−4
• Setup.lhs +12/−1
• pio.hs +54/−0
• src/Text/PageIO.hs +4/−0
• src/Text/PageIO/Extract.hs +34/−15
• src/Text/PageIO/Index.hs +299/−0
• src/Text/PageIO/Infer.hs +167/−0
• src/Text/PageIO/LabelMap.hs +3/−0
• src/Text/PageIO/Parser.hs +193/−142
• src/Text/PageIO/Transform.hs +268/−77
• src/Text/PageIO/Types.hs +24/−2

@@ -1,5 +1,5 @@ name:               PageIO-version:            0.0.2+version:            0.0.3 copyright:          2008 Audrey Tang license:            BSD3 license-file:       LICENSE@@ -12,13 +12,25 @@                     (Extremely experimental, no documentations at the moment!) stability:          experimental build-type:         Simple-extensions:         GeneralizedNewtypeDeriving, RecordPuns, ParallelListComp, PatternGuards+extensions:         GeneralizedNewtypeDeriving, RecordPuns, ParallelListComp, PatternGuards, PatternSignatures 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+                    Text.PageIO.Infer Text.PageIO.Index+build-depends:      base, array, bytestring, attoparsec >= 0.4, containers,+                    stringtable-atom, iconv, uuid, sqlite, utf8-string,+                    network, base64-string, regex-compat, regex-base, regex-tdfa, old-time, directory extra-source-files: README+extra-lib-dirs:     /usr/lib /usr/local/lib+include-dirs:       /usr/include /usr/local/include hs-source-dirs:     src category:           Text-ghc-options:        -O2+-- ghc-options:        -O++executable:         pio+main-is:            pio.hs+hs-source-dirs:     ., src+extra-lib-dirs:     /usr/lib /usr/local/lib+include-dirs:       /usr/include /usr/local/include+-- ghc-options:        -prof -auto-all

@@ -1,3 +1,14 @@ #!/usr/bin/env runhaskell > import Distribution.Simple-> main = defaultMain+> import System.Cmd+> import System.Exit+> import System.Directory+> main = defaultMainWithHooks (simpleUserHooks { runTests = quickCheck } )+>     where+>     quickCheck _ _ _ _ = do+>         ec <- system $ "ghc --make -odir dist/build -hidir dist/build -idist/build:src t/runTests.hs -L/usr/lib -liconv -luuid -o t/runTests"+>         case ec of+>             ExitSuccess -> do+>                 system "t/runTests"+>             _           -> return ec+>         return ()

@@ -0,0 +1,54 @@+module Main where+import Text.PageIO+import System.Exit+import System.Environment (getArgs, getProgName)++import Codec.Text.IConv+import qualified Data.ByteString.Char8 as S++main :: IO ()+main = do+    args            <- getArgs+    case args of+        ("--dump":rest) -> do+            (_, docs)   <- runFromArgs rest+            (`mapM_` docs) $ \(MkDoc _ lns) -> do+                let lns' = S.lines . packLBS $ convert "CP950" "UTF-8" lns+                (`mapM_` lns') $ S.putStrLn+        ("--meta":rest) -> do+            (_, docs)   <- runFromArgs rest+            (`mapM_` docs) $ \(MkDoc meta _) -> print meta+        _   -> do+            (sheet, docs)   <- runFromArgs args+            indexDocs sheet docs++runFromArgs args = case args of+    [fileIn] -> do+        pagesIn  <- readPages fileIn++        let docs = parsePages sheetIn pagesIn+            sheetIn = inferSheet fileIn pagesIn+        return (sheetIn, docs)++    [fileIn, duxIn] -> do+        sheetIn  <- readSheet duxIn+        pagesIn  <- readPages fileIn++        let docs = parsePages sheetIn pagesIn+        return (sheetIn, docs)++    (fileIn:duxIn:fileOut:duxOut:_) -> do+        sheetIn  <- readSheet duxIn+        sheetOut <- readSheet duxOut++        pagesIn  <- readPages fileIn+        pagesOut <- readPages fileOut++        let docs = transformPages sheetIn pagesIn sheetOut pagesOut+        return (sheetOut, docs)++    _ -> do+        prog <- getProgName+        putStrLn $ "Usage: " ++ prog ++ " input.txt [input.dux] [output.txt] [output.dux]"+        exitWith ExitSuccess+

@@ -3,8 +3,12 @@     , module Text.PageIO.Parser     , module Text.PageIO.Transform     , module Text.PageIO.Extract+    , module Text.PageIO.Index+    , module Text.PageIO.Infer     ) where import Text.PageIO.Run import Text.PageIO.Parser import Text.PageIO.Transform import Text.PageIO.Extract+import Text.PageIO.Index+import Text.PageIO.Infer

@@ -1,19 +1,22 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, RecordPuns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, RecordPuns, PatternGuards #-} {-# OPTIONS -fno-warn-name-shadowing -funbox-strict-fields #-}  module Text.PageIO.Extract where import Data.Maybe import Data.Monoid import Text.PageIO.Types+import Control.Applicative import qualified Text.PageIO.LabelMap as LM import qualified Data.ByteString.Char8 as S  type Area = Page-newtype BlockResult = MkBlockResult { blockResults :: [(Area, LabelMap Value)] }+newtype BlockResult = MkBlockResult { blockResults :: [(Area, LabelMap Bound)] }     deriving (Eq, Ord, Monoid) +type Bound = Value+ data SheetResult = MkSheetResult-    { resultFields  :: !(LabelMap Value)+    { resultFields  :: !(LabelMap Bound)     , resultBlocks  :: !(LabelMap BlockResult)     }     deriving (Eq, Ord)@@ -53,17 +56,18 @@         }     | 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+--    sheetArea = crop sheetBox page+    sheetArea = page+    patternResults = checkPattern sheetArea <$> LM.elems sheetPatterns+    fieldResults   = extractField sheetArea <$> sheetFields+    frameResults   = LM.unionsWith mappend $ extractFrame <$> sheetFrames+    extractFrame MkFrame{ frameBox, frameBlocks } = LM.fromListWith mappend $ reverse 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))+crop MkBox{boxTop, boxBottom, boxLeft, boxRight} (MkPage lns) = MkPage $ doCol <$> doRows lns     where     doRows = take (boxBottom - boxTop + 1) . drop (boxTop - 1)     doCol = S.take (boxRight - boxLeft + 1) . S.drop (boxLeft - 1)@@ -75,13 +79,28 @@     where     val = pageVal $ crop patternBox page -extractField :: Page -> Field -> Value-extractField page MkField{ fieldBox, fieldFormat } = case fieldFormat of+extractField :: Page -> Field -> Bound+extractField page fld@MkField{ fieldBox, fieldFormat } = case fieldFormat of+--    FNumeric 2  -> formatDotted (fieldLen fld) (S.unpack (valToIntVal val))     FNumeric{}  -> valToIntVal val-    _           -> val+    _ | Just idx <- S.elemIndexEnd '.' val+      , frac <- S.drop idx val+      -> S.append (formatDotted (fieldLen fld - S.length frac) (show $ valToInt val)) frac+      | otherwise -> val     where     val = pageVal $ crop fieldBox page +fieldLen :: Field -> Int+fieldLen MkField{ fieldBox } = boxRight fieldBox - boxLeft fieldBox + 1++formatDotted len n = S.pack $ (replicate pad ' ') ++ dottedStr+    where+    pad         = len - length dottedStr + 3+    str         = n+    dottedStr   = reverse (addDot $ reverse str)+    addDot (x:y:z:rest@(_:_))   = (x:y:z:',':addDot rest)+    addDot xs                   = xs+ extractBlocks :: LabelMap Block -> Page -> [(Label, BlockResult)] extractBlocks blocks page@(MkPage lns) = case blockResults of     []              -> case lns of@@ -104,12 +123,12 @@     | otherwise                       = Nothing     where     blockArea       = take blockLines lns-    patternResults  = map (checkPattern page) (LM.elems blockPatterns)-    fieldResults    = fmap (extractField page) blockFields+    patternResults  = checkPattern page <$> LM.elems blockPatterns+    fieldResults    = extractField page <$> blockFields     filtersPass     = all runFilter blockFilterBy     runFilter (flt@MkFilter{ filterField, filterOperator, filterMatch })         = case LM.lookup filterField fieldResults of-            Just val    -> case filterOperator of+            Just val -> case filterOperator of                 ONot op     -> not $ runFilter flt{ filterOperator = op }                 OContains   -> val `matches` filterMatch                 OStartsWith -> matchValue filterMatch `S.isPrefixOf` val 

@@ -0,0 +1,299 @@+{-# LANGUAGE RecordPuns #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+module Text.PageIO.Index where+import Codec.Text.IConv+import Control.Exception (try)+import Control.Monad (unless)+import Data.Char (isSpace)+import Data.List (nub, sort, intersperse)+import Data.Monoid (mappend)+import Database.SQLite+import System.Environment+import System.Time+import Debug.Trace+import Text.PageIO.Extract+import Text.PageIO.Parser (packLBS)+import Text.PageIO.Transform+import Text.PageIO.Types+import Text.Printf+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.UTF8 as UTF8+import qualified Text.PageIO.LabelMap as LM++addTables dbh = mapM_ (execStatement_ dbh)+    [ "CREATE VIRTUAL TABLE doc USING FTS3 ( head TEXT, body TEXT )"+    , "CREATE TABLE idx ( pri_nid TEXT, sec_nid TEXT, doc_name INT )"+    , "CREATE UNIQUE INDEX doc_name_idx ON idx (doc_name)"+    , "CREATE TABLE txt ( body TEXT )"+    ]++addColumn dbh cols = (`mapM_` cols) $ \col -> mapM_ (execStatement_ dbh)+    [ "ALTER TABLE idx ADD COLUMN '" ++ col ++ "' COLLATE NOCASE"+    , "CREATE INDEX '" ++ col ++ "_idx' ON idx ('" ++ col ++ "' COLLATE NOCASE)"+    ]++indexDocs :: Sheet -> [Doc] -> IO ()+indexDocs MkSheet{ sheetName, sheetFields, sheetFrames, sheetBox = MkBox{ boxRight, boxBottom } } docs = do+    env <- getEnvironment++    let dbName = case lookup "PIO_DB" env of+            Just n  -> n+            _       -> LM.fromLabel sheetName++    putStr dbName++    dbh <- openConnection $ dbName ++ ".db"++    -- XXX - Suspicious overload: pri_nid means "cols" and sec_nid means "rows"+    addTables dbh+    addColumn dbh columns++    dbhDetails <- case lookup "PIO_DETAILS_DB" env of+        Just n -> do+            h <- openConnection $ n ++ ".db"+            addTables h+            addColumn h ("fulltext":detailColumns)+            execStatement_ h "BEGIN EXCLUSIVE TRANSACTION"+            return (Just h)+        _ -> return Nothing++    execStatement_ dbh "BEGIN EXCLUSIVE TRANSACTION"++    (`mapM_` ([1..] `zip` docs)) $ \(docIndex, MkDoc meta contents) -> try $ do+        putStr "."+        let fields  = resultFields meta+            body    = UTF8.toString . packLBS $ convert "CP950" "UTF-8" contents++        let valOf x = LM.lookup (LM.toLabel x) fields+            year = case valOf "year_roc" of+                Just year_roc   -> valToInt year_roc + 11+                _               -> case valOf "year" of+                    Just year   -> valToInt year+                    _           -> 0+            r_date  | year == 0   = "0"+                    | otherwise   =+                let month = maybe 1 valToInt (valOf "month")+                    day   = maybe 1 valToInt (valOf "day")+                 in fromYMD (fixY2K year) month day++            fixY2K year | year >= 1900  = year+                        | year >= 70    = 1900 + year+                        | otherwise     = 2000 + year++        let attrsVanilla =+                [ (LM.fromLabel lbl, dropWhile isSpace (decode val))+                | (lbl, val) <- LM.toList fields+                ]+            -- XXX - Blob?+            decode bound = UTF8.toString . packLBS $ convert "CP950" "UTF-8" (L.fromChunks [bound]) +            attrs = (("r_id", LM.fromLabel sheetName):("r_date", r_date):attrsVanilla)+            attrHead = unlines (map snd attrs)+            cols = concatMap ((++ "'") . (", '" ++) . fst) attrs+            prms = concatMap ((++ "'") . (", '" ++) . snd) attrs++        execStatement_ dbh $ concat+            [ "INSERT INTO doc (head, body) VALUES ('"+            , attrHead+            , "', '"+            , body+            , "')"+            ]++        execStatement_ dbh $ concat+            [ "INSERT INTO idx (doc_name, pri_nid, sec_nid"+            , cols +            , ") VALUES (last_insert_rowid(), "+            , show boxRight+            , ", "+            , show boxBottom+            , prms+            , ")"+            ]++        let blocks  = LM.elems $ resultBlocks meta++        case dbhDetails of+            Just h -> do+                execStatement_ h $ concat+                    [ "INSERT INTO txt (rowid, body) VALUES ("+                    , show docIndex+                    , ", '"+                    , body+                    , "')"+                    ]+                (`mapM_` foldl blockProduct [] blocks) $ \(area, vals) -> try $ unless (LM.null vals) $ do+                    let attrsBlock =+                            [ (LM.fromLabel lbl, dropWhile isSpace (decode val))+                            | (lbl, val) <- LM.toList vals+                            ]+                        attrs' = attrs ++ map maybeFix attrsBlock+                        attrHead' = unlines (map snd attrs')+                        cols' = concatMap ((++ "'") . (", '" ++) . fst) attrs'+                        prms' = concatMap ((++ "'") . (", '" ++) . snd) attrs'+                        maybeFix ("expiry_date", date) = ("expiry_date", parseDate date)+                        maybeFix (c@['F','D','S','D',x,'D'], date@(_:_))+                            | x == 'B' || x == 'E' || x == 'O'+                            = (c, parseDate date)+                        maybeFix x = x+                        parseDate date = fromYMD y m d+                            where+                            i = read date+                            y = 1911 + (i `div` 10000)+                            m = i `mod` 10000 `div` 100+                            d = i `mod` 100++                    execStatement_ h $ concat+                        [ "INSERT INTO doc (head, body) VALUES ('"+                        , attrHead'+                        , "', '"+                        , concatMap decode (pageLines area)+                        , "')"+                        ]++                    execStatement_ h $ concat+                        [ "INSERT INTO idx (doc_name, fulltext, pri_nid, sec_nid"+                        , cols'+                        , ") VALUES (last_insert_rowid(), '"+                        , show docIndex+                        , "', "+                        , show boxRight+                        , ", "+                        , show boxBottom+                        , prms'+                        , ")"+                        ]+                    return ()+            _ -> return ()+    execStatement_ dbh "COMMIT"++    case dbhDetails of+        Just h  -> execStatement_ h "COMMIT"+        _       -> return Nothing++    closeConnection dbh+    +    putStrLn "done!"+    where+    columns = nub $ sort ("r_date":"r_id":map LM.fromLabel (LM.keys sheetFields))+    detailColumns = nub $ sort ("r_date":"r_id":map LM.fromLabel (concatMap LM.keys (sheetFields : frameFields)))+    frameFields = concatMap (map blockFields . LM.elems . frameBlocks) sheetFrames++blockProduct :: [(Area, LabelMap Bound)] -> BlockResult -> [(Area, LabelMap Bound)]+blockProduct [] (MkBlockResult ys) = ys+blockProduct xs (MkBlockResult []) = xs+blockProduct xs (MkBlockResult ys) =+    [ (xa `mappend` ya, xb `mappend` yb)+    | (xa, xb)  <- xs+    , (ya, yb)  <- ys+    ]++fromYMD :: Int -> Int -> Int -> String+fromYMD y m d = case toClockTime cal of+    TOD sec _ -> show (succ (sec `div` 86400))+    where+    cal = CalendarTime+        { ctYear    = y+        , ctMonth   = toEnum (m-1)+        , ctDay     = d+        , ctHour    = 0+        , ctMin     = 0+        , ctSec     = 0+        , ctPicosec = 0+        , ctWDay    = Sunday+        , ctYDay    = 0+        , ctTZName  = "UTC"+        , ctTZ      = 0+        , ctIsDST   = False+        }+    +{-+import Codec.Binary.Base64.String+import Data.Maybe (fromJust)+import Data.UUID (generate, toStringUpper)+import Network.URI+import Text.HyperEstraier+import Text.PageIO.Extract+import Text.PageIO.Parser (packLBS)+import Text.PageIO.Transform+import Text.PageIO.Types+import System.Environment+import qualified Text.PageIO.LabelMap as LM+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++indexDocs :: Sheet -> [Doc] -> IO ()+indexDocs MkSheet{ sheetName, sheetBox = MkBox{ boxRight, boxBottom } } docs = do+    -- removeDirectoryRecursive "casket"+    withDatabase "casket" (Writer [Create [], WriteLock NoLock]) $ \db -> do+    withDatabase "Details" (Writer [Create[], Truncate [], WriteLock NoLock]) $ \db2 -> do+    (`mapM_` docs) $ \(MkDoc meta contents) -> try $ do+        doc     <- newDocument+        uuid    <- generate+        let fields  = resultFields meta+            lns     = S.lines . packLBS $ convert "CP950" "UTF-8" contents+            uri     = parseURI $ "urn:uuid:" ++ (toStringUpper uuid)++        setURI doc uri+        (`mapM_` lns) $ addText doc . UTF8.toString ++        let valOf x = LM.lookup (LM.toLabel x) fields+            year = case valOf "year_roc" of+                Just year_roc   -> valToInt year_roc + 11+                _               -> case valOf "year" of+                    Just year   -> valToInt year+                    _           -> 0+            r_date  | year == 0   = Nothing+                    | otherwise   =+                let month = maybe 1 valToInt (valOf "month")+                    day   = maybe 1 valToInt (valOf "day")+                 in Just $ printf "%04d-%02d-%02d 00:00:00"+                    (fixY2K year)+                    (month) +                    (day)+            fixY2K year | year >= 1900  = year+                        | year >= 70    = 1900 + year+                        | otherwise     = 2000 + year+        let addAttributes d = do+                (`mapM_` LM.toList fields) $ \(lbl, bound) -> try $ do+                    setAttribute d (LM.fromLabel lbl) $ Just+                        ( UTF8.toString . packLBS $ convert "CP950" "UTF-8" (L.fromChunks [bound]) )+                setAttribute d "__text__" $ Just (encode . L.unpack $ contents)+                setAttribute d "__cols__" $ Just (show boxRight)+                setAttribute d "__rows__" $ Just (show boxBottom)+                setAttribute d "r_date" r_date+                setAttribute d "r_id" $ Just (LM.fromLabel sheetName)+                setAttribute d "__index_code__" $ Just ""+                maybe (return ()) (addHiddenText doc) r_date+                addHiddenText doc (LM.fromLabel sheetName)++        addAttributes doc+        putDocument db doc []+        docID <- getId doc+        print (docID, fromJust uri)++        env <- getEnvironment+        unless (lookup "PIO" env == Just "1") $ do++        let blocks  = LM.elems $ resultBlocks meta+        (`mapM_` foldl blockProduct [] blocks) $ \(area, vals) -> try . unless (LM.null vals) $ do+            doc2    <- newDocument+            uuid2   <- generate+            let uri2 = parseURI $ "urn:uuid:" ++ (toStringUpper uuid2)+            setURI doc2 uri2++            (`mapM_` pageLines area) $ \val -> do+                addText doc2 $+                    ( UTF8.toString . packLBS $ convert "CP950" "UTF-8" (L.fromChunks [val]) )++            (`mapM_` LM.toList vals) $ \(lbl, val) -> do+                let str = UTF8.toString . packLBS $ convert "CP950" "UTF-8" (L.fromChunks [val])+                addHiddenText doc2 str+                setAttribute doc2 (LM.fromLabel lbl) $ Just str++            setAttribute doc2 "__index_code__" $ Just ""++            addAttributes doc2+            putDocument db2 doc2 []+            docID2 <- getId doc2+            print (docID2, fromJust uri2)+-}

@@ -0,0 +1,167 @@+{-# LANGUAGE RecordPuns, ParallelListComp, PatternGuards, PatternSignatures #-}+module Text.PageIO.Infer where+import Text.PageIO.Types+import Data.Char (isAlphaNum, toUpper)+import Data.Maybe (catMaybes)+import Data.Monoid+import Control.Applicative+import Data.Array (elems, (!))+import Text.Regex.TDFA+import Text.Regex.Base.RegexLike+import qualified Data.ByteString.Char8 as S+import qualified Text.PageIO.LabelMap as LM+import Debug.Trace++inferSheet :: FilePath -> [Page] -> Sheet+inferSheet fn pages = MkSheet+    { sheetName = name+    , sheetBox  = MkBox+        { boxTop    = 1+        , boxLeft   = 1+        , boxBottom = rows+        , boxRight  = cols+        }+    , sheetPatterns = mempty+    , sheetFields   = LM.fromList+        ( mkField "b_id" 1 1 4 1+        : case pages of+            []      -> []+            (p:_)   -> inferPageNameField p : inferPageDateFields p+        )+    , sheetFrames   = []+    , sheetOrderBy  = [toLabel "b_id"]+    , sheetGroupBy  = [toLabel "b_id"]+    , sheetUseBlockSortPriority = True+    }+    where+    lns     = pageLines <$> pages   +    rows    = maximum $ length <$> lns+    cols    = maximum $ S.length <$> concat lns+    name    = toLabel $ toUpper <$> takeWhile isAlphaNum fn++mkField :: String -> Col -> Row -> Col -> Row -> (Label, Field)+mkField lbl l t r b = (,) (toLabel lbl) MkField+    { fieldBox        = MkBox+        { boxLeft   = l+        , boxTop    = t+        , boxRight  = r+        , boxBottom = b+        }+    , fieldVariable   = Nothing+    , fieldKeepSpaces = False+    , fieldFormat     = FGeneral+    }++namePattern :: Value+namePattern = S.concat+    [ S.pack "(([^ ]+ {0,2})*[^ ]*("+    , keywords+    , S.pack ")[^< ]*)"+    ]+    where+    keywords = S.intercalate (S.pack "|") $ S.pack <$>+        [ "\xB3\xF8"    -- 報+        , "\xAA\xED"    -- 表+        , "\xB1\x62"    -- 帳+        , "\xC3\xAF"    -- 簿+        , "\xB3\xE6"    -- 單+        , "\xA5\x55"    -- 冊+        , "\xB2\xD3"    -- 細+        , "\xBF\xFD"    -- 錄+        , "\xB8\xEA"    -- 資+        , "\xAE\xC6"    -- 料+        , "\xAE\xD1"    -- 書+        , "\xC0\xC9"    -- 檔+        , "\xC1\x60"    -- 總+        , "\xAD\x70"    -- 計+        ]++datePattern :: Value+datePattern = S.pack $ concat+    [ "( {0,2}[0-9]{2,4} {0,2})"+    , "([^ 0-9]{1,4}|  )"+    , "( {0,3}[0-9]{1,2}) {0,2}"+    , "(([^ 0-9]{1,4}|  )"+    , "( {0,3}[0-9]{1,2} {0,1}))?"+    ]++data DateMatch = MkDateMatch+    { matchLine     :: Int+    , matchIsROC    :: Bool +    , matchYear     :: (Int, Int)+    , matchMonth    :: (Int, Int)+    , matchDay      :: Maybe (Int, Int)+    }+    deriving (Show, Eq, Ord)++inferPageNameField :: Page -> (Label, Field)+inferPageNameField page = case concatMap tryMatchName (take 6 lns) of+    []      -> mkField "r_name" 1 1 0 0 -- error "No r_name found!"+    (f:_)   -> f+    where+    lns = [1..] `zip` pageLines page++tryMatchName :: (Int, Value) -> [(Label, Field)]+tryMatchName (lineNum, content) =+    [ mkField "r_name" (start+delta+1) lineNum (start+len) lineNum+    | (text, (start, len)) <- (! (0 :: Int)) <$> content =~ namePattern+    , let delta = tryDelta text+    ]+    where+    tryDelta text = case text `matchSubstring` MkMatch commercialBank of+        Nothing     -> 0+        Just off    -> off + S.length commercialBank+    commercialBank = S.pack "\xB0\xD3\xB7\x7E\xBB\xC8\xA6\xE6\xA1\x40"++-- Algorithm: Find the first line with three consecutive integers+--            that looks sufficiently like a date.  We do so by+--            finding each 3-grams of digits close enough together+--            (distance 7 or less), then inspect the actual values,+--            then finally capture the spaces around them too.+--            If the year is >= 1900 then it's "year" else it's "year_roc".+inferPageDateFields :: Page -> [(Label, Field)]+inferPageDateFields page = case concatMap tryMatchDate lns of+    []      -> []+    (m:_)   -> dateMatchToFields m+    where+    lns = [1..] `zip` pageLines page++tryMatchDate :: (Int, Value) -> [DateMatch]+tryMatchDate (lineNum, content) =+    [ dateMatch{ matchLine = lineNum }+    | Just dateMatch <- validateMatch <$> reverse (content =~ datePattern)+    ]++validateMatch :: MatchText Value -> Maybe DateMatch+validateMatch match+    | month >= 1, month <= 12, day >= 1, day <= 31+    = Just MkDateMatch+        { matchLine     = undefined+        , matchIsROC    = year < 1900+        , matchYear     = yearPos+        , matchMonth    = monthPos+        , matchDay      = if S.null dayText then Nothing else Just dayPos+        }+    | otherwise+    = Nothing+    where+    [ _, (yearText,  yearPos)+       , _+       , (monthText, monthPos)+       , _+       , _+       , (dayText,   dayPos) ] = elems match+    [year, month, day] = valToInt <$> [yearText, monthText, dateText']+    dateText' | S.null dayText  = S.singleton '1'+              | otherwise       = dayText++dateMatchToFields :: DateMatch -> [(Label, Field)]+dateMatchToFields MkDateMatch{ matchLine, matchIsROC, matchYear, matchMonth, matchDay } =+    ( dateField yearLabel matchYear+    : dateField "month" matchMonth+    : maybe [] ((:[]) . dateField "day") matchDay+    )+    where+    dateField lbl (start, len) = mkField lbl (start+1) matchLine (start+len) matchLine+    yearLabel = if matchIsROC then "year_roc" else "year"+

@@ -72,6 +72,9 @@ filter :: (a -> Bool) -> LabelMap a -> LabelMap a filter f = MkLabelMap . IM.filter f . labelMap +null :: LabelMap a -> Bool+null = IM.null . labelMap+ mapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b mapMaybe f = MkLabelMap . IM.mapMaybe f . labelMap 

@@ -1,133 +1,163 @@ module Text.PageIO.Parser where -import Text.Parsec-import Text.Parsec.ByteString-import Data.Char (isDigit)+import Codec.Text.IConv+import Control.Applicative import Data.ByteString.Lazy.Char8 (pack, ByteString, toChunks)-import Text.PageIO.Types-import Control.Monad (liftM3, liftM4)+import Data.Maybe+import Data.ParserCombinators.Attoparsec.Char8 import Numeric (readDec)-import Codec.Text.IConv+import Text.PageIO.Types import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L import qualified Text.PageIO.LabelMap as LM +liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftA4 f a b c d = f <$> a <*> b <*> c <*> d++liftA5 :: Applicative f => (a -> b -> c -> d -> e -> result) -> f a -> f b -> f c -> f d -> f e -> f result+liftA5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e++(<$$>) :: Functor f => f a -> (a -> b) -> f b+(<$$>) = flip (<$>)+ readSheet :: FilePath -> IO Sheet-readSheet fn = do-    rv <- parseFromFile sheet fn-    case rv of-        Right s     -> return s-        Left err    -> fail $ show err+readSheet fn = either (error . show) id+    <$> parseFromFile sheet fn +parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname = do+    input <- L.readFile fname+    return . snd $ parse p input+ parseMaybe :: Parser a -> Parser (Maybe a)-parseMaybe r = fmap Just r <|> return Nothing+parseMaybe p = Just <$> p+    <|> return Nothing  maybeFieldVariable :: Parser (Maybe Variable)-maybeFieldVariable = parseMaybe $ do+maybeFieldVariable = parseMaybe $     char '$'-    choice-        [ char '$'   >> fmap VLabel bareLabel-        , sym "PAGE" >> return VPage+    *> choice+        [ VLabel <$> (char '$' *> bareLabel)+        , VPage  <$ sym "PAGE"         , literalVariable         , functionVariable+        , substrVariable+        , replaceVariable         ]  literalVariable :: Parser Variable-literalVariable = do-    s <- literalStr-    ret $ VLiteral s+literalVariable = r$ VLiteral <$> literalStr  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 <- bareLabel-    sym ")"-    return $ fun scope fld+functionVariable =+    ($) <$> choice+            [ VSum   <$ sym "SUM("+            , VCount <$ sym "COUNT("+            ]+        <*> choice+            [ SDoc   <$ sym "doc."+            , SPage  <$ optional (sym "page.")+            ]+        <*> bareLabel+    <* sym ")" +substrVariable :: Parser Variable+substrVariable = between (sym "SUBSTR(") (sym ")") $+    liftA3 VSubStr+        (bareLabel  <* sym ",")+        (num        <* sym ",")+        (num)++replaceVariable :: Parser Variable+replaceVariable = between (sym "REPLACE(") (sym ")") $+    liftA2 VReplace (bareLabel <* sym ",")+                    (getPairs <$> literalStr `sepEndBy` sym ",")+    where+    getPairs []       = []+    getPairs [x]      = [(x, S.empty)]+    getPairs (x:y:zs) = ((x, y):getPairs zs)+ bareLabel :: Parser Label-bareLabel = do-    s   <- many1 $ noneOf ".;) "-    ret $ toLabel s+bareLabel = r$ toLabel <$> many1 (noneOf ",.;) ")  maybeFieldFormat :: Parser (Maybe FieldFormat)-maybeFieldFormat = parseMaybe $ do +maybeFieldFormat = parseMaybe $     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)+    *> choice+        [ FNumeric 0 <$ sym "\"NZ ZZZ ZZ9,99\""+        , FNumeric 0 <$ sym "\"Nk= d=.\""+        , FNumeric 2 <$ sym "\"NZ,ZZZ,ZZZ,ZZ#.##\""         ]  maybeFilters :: Parser (Maybe [Filter])-maybeFilters = parseMaybe $ do-    sym "WHERE"+maybeFilters = parseMaybe $+    sym "WHERE" *>     parseFilter `sepEndBy` sym "AND"  parseFilter :: Parser Filter-parseFilter = liftM3 MkFilter parseLabel operator (fmap mkMatch quotedValue)+parseFilter = liftA3 MkFilter+    parseLabel+    operator+    (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)+    [ ONot      <$> (sym "NOT" *> operator)+    , OContains   <$ sym "CONTAINS"+    , OStartsWith <$ sym "STARTSWITH"+    , OEndsWith   <$ sym "ENDSWITH"+    , OEq         <$ sym "=="+    , OEq         <$ sym "="+    , ONot OEq    <$ sym "!="+    , ONot OEq    <$ sym "<>"     ] +commaSep :: Parser a -> Parser [a]+commaSep = (`sepEndBy` sym ",")+ 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+maybeOrderBys = r$ parseMaybe $+    sym "ORDER" *>+    sym "BY" *> (+        commaSep $ do+            lbl <- parseLabel+            choice+                [ DDescending lbl <$ sym "DESC"+                , DAscending lbl  <$ optional (sym "ASC")+                ]+    )  maybeBy :: String -> Parser (Maybe [Label])-maybeBy by = parseMaybe $ do-    sym by-    sym "BY"-    lbls <- parseLabel `sepEndBy` sym ","-    ret $ lbls+maybeBy by = r$ parseMaybe $+    sym by *>+    sym "BY" *>+    commaSep parseLabel  maybeRule :: Parser (Maybe a) -> Parser (Maybe a)-maybeRule p = (<|> return Nothing) $ do-    between (sym "Rule" >> sym "\"") (sym "\";") p+maybeRule p = +    between (sym "Rule" *> sym "\"") (sym "\";") p+        <|> return Nothing  parseLabel :: Parser Label-parseLabel = do-    s   <- many (noneOf "\", ") -    ret $ toLabel s+parseLabel = r$ toLabel <$> many (noneOf "\", ") +r :: Parser a -> Parser a+r = (<* sp)+ sheet :: Parser Sheet-sheet = do-    sym "Event"+sheet = r$ between (sym "Event") (sym "End") $ do     name    <- labelStr     manyTill anyChar (sym "UseCharPos" <|> sym "UseGridPos")     sym "Sheet"     right   <- num     bottom  <- num-    optional (sym "UsePriority")+    pri     <- (True <$ sym "UsePriority") <|> return False     pats    <- many pattern-    grp     <- maybeRule $ maybeBy "GROUP"+    (grp, odr) <- (fromMaybe (Nothing, Nothing) <$>) . maybeRule $+        Just <$> ((,) <$> maybeBy "GROUP" <*> maybeBy "ORDER")     flds    <- many field     frames  <- many frame-    sym "End"-    ret $ MkSheet+    return $ MkSheet         { sheetName     = name         , sheetBox      = MkBox             { boxLeft   = 1@@ -140,39 +170,37 @@             | (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+        , sheetFrames   = frames <$$> \frm -> frm+            { frameBlocks = frameBlocks frm <$$> \blk -> blk+                { blockPatterns = blockPatterns blk <$$> \pat -> pat                     { patternBox = (patternBox pat){ boxRight = right }                     }                 }             }-        , sheetGroupBy  = maybe [] id grp+        , sheetOrderBy  = fromMaybe (fromMaybe [] grp) odr+        , sheetGroupBy  = fromMaybe [] grp+        , sheetUseBlockSortPriority = pri         }  sym :: String -> Parser ()-sym s = try (string s) >> sp--ret :: a -> Parser a-ret x = sp >> return x+sym s = try (string (pack s)) *> sp  sp :: Parser ()-sp = skipMany (space <|> (try (string "//") >> skipMany (noneOf ['\n']) >> anyChar))+sp = skipMany (space <|> (try (string (pack "//")) *> skipMany (notChar '\n') *> anyChar))  num :: Parser Int-num = do-    digits <- many1 digit-    ret $ fst (head $ readDec digits)+num = r$ fst . head . readDec <$> many1 digit  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+pattern = r$ sym "Match"+    *> liftA5 ret+        labelStr+        num+        num+        matchStr+        (True <$ sym "UseWildCards" <|> return False)+    where+    ret lbl left top mat wc = (,) lbl MkPattern         { patternBox    = MkBox             { boxLeft   = left             , boxTop    = top@@ -184,51 +212,47 @@         }  field :: Parser (Label, Field)-field = do-    sym "Field"-    lbl <- labelStr-    box <- boxNumbers-    var <- maybeFieldVariable-    fmt <- maybeFieldFormat-    char ';'-    retLabel lbl MkField+field = between (sym "Field") (sym ";") $+    liftA4 ret+        labelStr+        boxNumbers+        maybeFieldVariable+        maybeFieldFormat+    where+    ret lbl box var fmt = (,) lbl MkField         { fieldBox         = box         , fieldKeepSpaces  = True         , fieldVariable    = var-        , fieldFormat      = maybe FGeneral id fmt+        , fieldFormat      = fromMaybe FGeneral fmt         }  boxNumbers :: Parser Box-boxNumbers = liftM4 MkBox num num num num+boxNumbers = liftA4 MkBox num num num num  frame :: Parser Frame-frame = do-    sym "Frame"-    box     <- boxNumbers-    blocks  <- many block-    sym "End"-    ret $ MkFrame+frame = between (sym "Frame") (sym "End")+    $ liftA2 ret+        boxNumbers+        (many block)+    where+    ret box blocks = MkFrame         { frameBox    = box         , frameBlocks = LM.fromList blocks         }  retLabel :: Label -> a -> Parser (Label, a)-retLabel l x = ret (l, x)+retLabel l x = (l, x) <$ sp  block :: Parser (Label, Block)-block = do-    sym "Block"+block = between (sym "Block") (sym "End") $ do     lbl     <- labelStr-    optional (sym "UsePriority")+    pri     <- (True <$ sym "UsePriority") <|> return False     sym "Lines"     lns     <- num     pats    <- many pattern-    (filters, orders) <- fmap (maybe (Nothing, Nothing) id) . maybeRule $ do-        filters <- maybeFilters-        orders  <- maybeOrderBys-        return (Just (filters, orders))+    (filters, groups, orders) <- (fromMaybe (Nothing, Nothing, Nothing) <$>) . maybeRule $+        Just <$> ((,,) <$> maybeFilters <*> maybeBy "GROUP" <*> maybeOrderBys)     flds    <- many field-    sym "End"     retLabel lbl MkBlock         { blockLines    = lns         , blockPatterns = LM.fromList@@ -239,22 +263,24 @@             [ (l, fld{ fieldBox = adjustBox box })             | (l, fld) <- flds, let box = fieldBox fld             ]-        , blockOrderBy  = maybe [] id orders-        , blockFilterBy = maybe [] id filters+        , blockOrderBy  = fromMaybe (DAscending <$> fromMaybe [] groups) orders+        , blockGroupBy  = fromMaybe [] groups+        , blockFilterBy = fromMaybe [] filters+        , blockUsePriority = pri         }     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)+    adjustBox (MkBox left top right bottom) = MkBox (left+1) (top+1) (right+1) (bottom+1)  literalStr :: Parser Value -literalStr = do-    beginQuote  <- oneOf "\"'"-    s           <- many (noneOf [beginQuote])-    char beginQuote-    ret . packLBS . convert "UTF-8" "CP950" $ pack s+literalStr = r$ do+    beginQuote <- oneOf "\"'"+    packLBS . convert "UTF-8" "CP950" . pack+        <$> many (noneOf [beginQuote])+            <* char beginQuote  matchStr :: Parser Match-matchStr = fmap (mkMatch . packLBS . convert "UTF-8" "CP950") str+matchStr = mkMatch . packLBS . convert "UTF-8" "CP950" <$> str  mkMatch :: Value -> Match mkMatch s = MkMatch $ S.init (s `S.append` S.singleton '\0')@@ -263,18 +289,43 @@ packLBS = S.concat . toChunks  labelStr :: Parser Label-labelStr = fmap (toLabel . packLBS) str+labelStr = toLabel . packLBS <$> str  str :: Parser ByteString-str = do-    char '"'-    s <- many (noneOf ['"'])-    char '"'-    ret $ pack s+str = pack <$> (char '"' *> many (noneOf ['"']) <* char '"' <* sp)  quotedValue :: Parser Value-quotedValue = do-    beginQuote  <- oneOf "\"'"-    s           <- many (noneOf [beginQuote])-    char beginQuote-    ret $ S.pack s+quotedValue = r$ do+    beginQuote <- oneOf "\"'"+    S.pack <$> many (noneOf [beginQuote])+                <* char beginQuote++--- Alternative combinators++sepEndBy :: Alternative f => f a -> f b -> f [a]+sepEndBy p sep = sepEndBy1 p sep <|> pure []++sepEndBy1 :: Alternative f => f a -> f b -> f [a]+sepEndBy1 p sep = (:) <$> p <*> next+    where+    next = sep *> sepEndBy p sep+        <|> pure []++many1 :: Alternative f => f a -> f [a] +many1 p = (:) <$> p <*> many p++choice :: Alternative f => [f a] -> f a+choice ps = foldr (<|>) empty ps++--- Parser specific++between :: Parser a -> Parser b -> Parser c -> Parser c+between open close p = open *> p <* close++--- Char8 Parser specific++oneOf :: [Char] -> Parser Char+oneOf = satisfy . flip elem++noneOf :: [Char] -> Parser Char+noneOf = satisfy . flip notElem

@@ -5,14 +5,17 @@ import Data.Maybe import Data.Monoid import Data.Function (on)-import Data.List (find, inits, tails, sortBy, groupBy, intersperse)+import Data.List (find, inits, tails, sortBy, groupBy, intersperse, mapAccumR, sort) import Text.Printf+import Text.Regex+import Control.Applicative import qualified Text.PageIO.LabelMap as LM import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L +import Debug.Trace import Text.PageIO.Types-import Text.PageIO.Extract (extractPage, SheetResult(..), BlockResult(..), Area)+import Text.PageIO.Extract (extractPage, SheetResult(..), BlockResult(..), Area, Bound(..), crop, fieldLen, formatDotted)  data Doc = MkDoc     { docMeta    :: !SheetResult@@ -38,7 +41,7 @@  data BlockData = MkBlockData     { dataSize      :: !Row-    , dataAreas     :: ![Ordered Area]+    , dataAreas     :: ![Ordered FieldBinding]     }     deriving (Eq, Ord, Show) @@ -55,17 +58,21 @@ type FitAttempt = LabelMap BlockData  -- The actual data bound to that area.-type PageBinding = LabelMap [Area]+type PageBinding = LabelMap [FieldBinding]+type FieldBinding = (Area, LabelMap Bound)  parsePages :: Sheet -> [Page] -> [Doc] parsePages sheetIn pagesIn = map emitDoc docGroupsOut     where     docGroupsOut = case sheetGroupBy sheetIn of-        []      -> [resultsIn]-        lbls    -> groupBy ((==) `on` docKeys) resultsIn+        []      -> [map snd resultsIn]+        lbls    -> map (map snd) $ groupBy ((==) `on` docKeys) $ sortBy (compare `on` docKeys) resultsIn             where-            docKeys (res, _) = map (`LM.lookup` resultFields res) lbls-    resultsIn = [ (res, page) | (Just res, page) <- map (\p -> (extractPage sheetIn p, p)) pagesIn ]+            docKeys (vm, _) = map (`LM.lookup` vm) lbls+    resultsIn =+        [ (makeValueMap res, (res, page))+        | (Just res, page) <- map (\p -> (extractPage sheetIn p, p)) pagesIn+        ]  emitDoc :: [(SheetResult, Page)] -> Doc emitDoc xs = MkDoc meta (packPages pages)@@ -82,24 +89,33 @@     bindingsOut = concatMap (bindDoc sheetOut pagesOut) docGroupsIn     docGroupsOut = case sheetGroupBy sheetOut of         []      -> [bindingsOut]-        lbls    -> groupBy ((==) `on` docKeys) bindingsOut+        lbls    -> groupBy ((==) `on` docKeys)+            $ sortBy (compare `on` docKeys) bindingsOut             where-            docKeys MkDocBinding{ docResult } = map (`LM.lookup` resultFields docResult) lbls-    docGroupsIn = case sheetGroupBy sheetIn of-        []      -> [resultsIn]-        lbls    -> groupBy ((==) `on` docKeys) resultsIn+            docKeys MkDocBinding{ docValueMap } = map (`LM.lookup` docValueMap) lbls+    docGroupsIn = case groupBys of+        []      -> [map snd resultsIn]+        lbls    -> map (map snd)+            $ groupBy ((==) `on` docKeys)+            $ sortBy (compare `on` docKeys) resultsIn             where-            docKeys res = map (`LM.lookup` resultFields res) lbls-    resultsIn = [ res | Just res <- map (extractPage sheetIn) pagesIn ]+            docKeys (vm, _) = map (`LM.lookup` vm) lbls+        where+        -- Really `melse`+        groupBys = case sheetOrderBy sheetIn of+            []  -> sheetOrderBy sheetOut+            xs  -> xs+    resultsIn = [ (makeValueMap res, 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-    ]+makeDoc sheetOut xs = MkDoc meta (packPages pages)     where-    meta = mconcat results+    meta = mconcat . catMaybes $ map (extractPage $ constToPattern sheetOut) pages+    pages = map (crop (sheetBox sheetOut)) $ fillVariables sheetOut results+        [ makePage sheetOut b p+        | b <- map docBinding xs+        | p <- map docPage xs+        ]     results = map docResult xs  packPages :: [Page] -> L.ByteString@@ -124,7 +140,8 @@ -- XXX - If data would expand, then maybe repeat the first page indefinitely? -- data DocBinding = MkDocBinding-    { docResult     :: !SheetResult+    { docValueMap   :: !ValueMap+    , docResult     :: !SheetResult     , docPage       :: !Page     , docBinding    :: !PageBinding     }@@ -133,31 +150,104 @@ 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+        [ MkDocBinding (makeValueMap r) r p b         | r <- boundResults         | b <- bindings         | p <- boundPages         ]     _  -> []     where-    resultsOut          = map (maybe (error "Roundtrip failed!") id . extractPage sheetOut) pagesOut+    resultsOut          = fromMaybe (error "Roundtrip failed!") . extractPage sheetOut+                      <$> pagesOut     orders              = sheetBlockOrderBys sheetOut-    capacity            = foldr (doCapacity sheetOut) [] resultsOut -    attempt             = foldr (doAttempt orders) mempty resultsIn+    capacity            = foldl (doCapacity sheetOut) [] resultsOut +    attempt             = foldl (doAttempt orders) mempty resultsIn     capacityTails       = repeatTails capacity     pageTails           = repeatTails pagesOut     resultTails         = repeatTails resultsIn     pageBindings        = -        [ (tryFit pc sortedAttempt, pages', results')+        [ (tryFit pc groupedAttempt, pages', results')         | pc        <- capacityTails         | pages'    <- pageTails         | results'  <- resultTails         ]-    sortedAttempt       = (`fmap` filteredAttempt) $ \dat ->+    groupedAttempt      = LM.mapWithKey (doGroupBlockData groups fields) sortedAttempt+        where+        groups              = sheetBlockGroupBys sheetOut+        fields              = sheetBlockFields sheetOut+    sortedAttempt       = (<$> filteredAttempt) $ \dat ->         dat{ dataAreas = sortBy (compare `on` fst) $ dataAreas dat }     filteredAttempt     = attempt `LM.intersection` capacityLabels     capacityLabels      = LM.fromList [ (k, ()) | k <- concatMap (concatMap slotBlocks) capacity ] +-- This is positively weird.+-- We want to somehow collapse all rows into one, and calculate their+-- variables "right here".+doGroupBlockData :: LabelMap [Label] -> LabelMap (LabelMap Field) -> Label -> BlockData -> BlockData+doGroupBlockData allGroups allFields lbl dat+    | Just groups@(_:_) <- LM.lookup lbl allGroups+    , Just fields <- LM.lookup lbl allFields+    = dat{ dataAreas = doGroupArea groups fields (dataAreas dat) }+    | Just fields <- LM.lookup lbl allFields+    = dat{ dataAreas = doExpandFields fields <$> dataAreas dat }+    | otherwise+    = dat{ dataAreas = sort $ dataAreas dat }++doExpandFields :: LabelMap Field -> Ordered FieldBinding -> Ordered FieldBinding+doExpandFields fields (order, (area, bounds)) = (order, (area, bounds'))+    where+    bounds' = LM.mapWithKey doExpandField fields+    doExpandField lbl fld+        | Just var   <- fieldVariable fld+        = case var of+            VLiteral lit        -> lit+            VSubStr label d t   -> maybe S.empty (S.take t . S.drop d)+                $ LM.lookup label bounds+            VReplace label mrs  -> maybe S.empty (\v -> foldl (flip $ uncurry replaceWith) v mrs)+                $ LM.lookup label bounds+            _               -> val+        | otherwise+        = val+        where+        val = fromMaybe S.empty (LM.lookup lbl bounds)+++replaceWith :: Value -> Value -> Value -> Value+replaceWith match replace str+    | match == S.singleton '$'+    = str `S.append` replace+    | match == S.singleton '^'+    = replace `S.append` str+    | otherwise+    = S.pack $ subRegex (mkRegex $ S.unpack match) (S.unpack str) (S.unpack replace)++-- type FieldBinding = (Area, LabelMap Bound)+doGroupArea :: [Label] -> LabelMap Field -> [Ordered FieldBinding] -> [Ordered FieldBinding]+doGroupArea groups fields xs = map (doGroupRows fields) $ groupBy ((==) `on` areaKeys) xs+    where+    -- XXX - Now groupby with "groups" and refill with vars! ("head" above is wrong)+    areaKeys (_, (_, bounds)) = (`LM.lookup` bounds) <$> groups++doGroupRows :: LabelMap Field -> [Ordered FieldBinding] -> Ordered FieldBinding+doGroupRows _ [] = error "Impossible"+doGroupRows fields xs@((order, (area, bounds)):_) = (order, (area, bounds'))+    where+    bounds' = LM.mapWithKey doGroupRow fields+    doGroupRow lbl fld+        | Just var   <- fieldVariable fld+        , len        <- fieldLen fld+        = case var of+            VLiteral lit        -> lit+            VCount{}            -> formatInt len $ length xs+            VSum{ vLabel = l }  -> formatFloat len . sum . map valToInt $ catMaybes+                [ LM.lookup l vs+                | (_, (_, vs)) <- xs+                ]+            _               -> val+        | otherwise = val+        where+        val = fromMaybe S.empty (LM.lookup lbl bounds)+ -- Given "abc", generate ["", "c", "bc", "abc", "aabc", "aaabc", "aaaabc"...] repeatTails :: [a] -> [[a]] repeatTails [] = []@@ -165,76 +255,102 @@     where     infinitePrefixes = inits (repeat x) +constToPattern :: Sheet -> Sheet+constToPattern sheet = sheet{ sheetFrames = doFrame <$> sheetFrames sheet }+    where+    doFrame frame = frame{ frameBlocks = doBlock <$> frameBlocks frame }+    doBlock block = block+        { blockPatterns = blockPatterns block `mappend` (LM.mapMaybe doField $ blockFields block) }+    doField field+        | Just (VLiteral lit) <- fieldVariable field+        = Just MkPattern+            { patternBox          = fieldBox field+            , patternMatch        = MkMatch lit+            , patternUseWildcards = False+            }+        | otherwise = Nothing+ -- We now calculate the applied vars for each page fillVariables :: Sheet -> [SheetResult] -> [Page] -> [Page] fillVariables sheet results pages =     [ fillPageVariables appliedVars p     | p             <- pages-    | appliedVars   <- map applyVariable ([1..] `zip` valueMaps)+    | appliedVars   <- applyVariable <$> [1..] `zip` valueMaps     ]     where-    vars        = sheetVariableFields sheet-    valueMaps   = map makeValueMap+    (fieldVars, frameVars) = sheetVariableFields sheet+    valueMaps   = makeValueMap <$>         [ MkSheetResult rf nr-        | MkSheetResult rf _  <- results-        | MkSheetResult _ nr <- newResults+        | MkSheetResult rf _    <- results+        | MkSheetResult _ nr    <- newResults         ]     docVals     = LM.unionsWith (++) valueMaps-    newResults  = map (maybe (error "1Roundtrip failed!") id . extractPage sheet) pages+    newResults  = fromMaybe err . extractPage sheet <$> pages+    err = error "Roundtrip failed during variable fill!"     applyVariable :: (Int, ValueMap) -> LabelMap AppliedVariable-    applyVariable (pageNum, pageVals) = LM.mapMaybeWithKey applyOneVariable vars+    applyVariable (pageNum, pageVals) =+        LM.mapMaybeWithKey (applyOneVariable False) fieldVars+            `LM.union`+        LM.mapMaybeWithKey (applyOneVariable True) frameVars         where-        applyOneVariable :: Label -> Field -> Maybe AppliedVariable-        applyOneVariable lbl MkField{ fieldBox, fieldVariable }+        applyOneVariable :: Bool -> Label -> Field -> Maybe AppliedVariable+        applyOneVariable isInFrame lbl fld@MkField{ fieldBox, fieldVariable }             | Just var <- fieldVariable-            , LM.member lbl pageVals  = Just MkAppliedVariable+            , if isInFrame then LM.member lbl pageVals else True+            = Just MkAppliedVariable                 { avRow     = boxTop fieldBox                 , avCol     = boxLeft fieldBox                 , avValue   = getVar var                 }             | otherwise                 = Nothing             where-            len = boxRight fieldBox - boxLeft fieldBox + 1+            len = fieldLen fld             valOf :: Scope -> Label -> [Value]-            valOf scope lbl = maybe [] id $ LM.lookup lbl vals+            valOf scope lbl = fromMaybe [] $ LM.lookup lbl vals                 where                 vals = case scope of                     SDoc    -> docVals                     SPage   -> pageVals-            getVar VPage                = formatNumber pageNum-            getVar (VSum scope label)   = formatDotted $ sum (map valToInt $ valOf scope label)-            getVar (VCount scope label) = formatNumber $ length (valOf scope label)+            getVar VPage                = formatInt len pageNum+            getVar (VSum scope label)   = case fieldFormat fld of+                FNumeric 2  -> (formatDotted (len-6) . show $ sum (valToInt <$> valOf scope label)) `S.append` S.pack ".00"+                _           -> formatInt len $ sum (valToInt <$> valOf scope label)+            getVar (VCount scope label) = formatInt len $ length (valOf scope label)             getVar (VLiteral lit)       = formatLiteral lit             getVar (VLabel label)       = formatLiteral $ case valOf SPage label of                 []      -> S.empty                 (x:_)   -> x+            getVar (VSubStr label d t)  = formatLiteral $ case valOf SPage label of+                []      -> S.empty+                (x:_)   -> S.take t (S.drop d x)+            getVar (VReplace label mrs)  = formatLiteral $ case valOf SPage label of+                []      -> S.empty+                (x:_)   -> foldl (flip $ uncurry replaceWith) x mrs             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-                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 +formatInt :: Int -> Int -> Value+formatInt len = S.pack . printf ("%" ++ show len ++ "d")++formatFloat :: Int -> Int -> Value+formatFloat len = S.pack . printf ("%" ++ show (len - 3) ++ "d.00")+ makeValueMap :: SheetResult -> ValueMap makeValueMap MkSheetResult{ resultFields, resultBlocks } = LM.unionsWith (++) (fieldMap:blockMaps)     where-    fieldMap  = fmap (:[]) resultFields+    fieldMap  = (:[]) <$> resultFields     blockMaps :: [ValueMap]-    blockMaps = map makeBlockValueMap $ LM.elems resultBlocks+    blockMaps = makeBlockValueMap <$> LM.elems resultBlocks     makeBlockValueMap :: BlockResult -> ValueMap     makeBlockValueMap (MkBlockResult avs) = LM.unionsWith (++) maps         where         maps :: [LabelMap [Value]]-        maps = map (fmap (:[]) . snd) avs+        maps = [ (:[]) <$> bound | (_, bound) <- 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+makePage MkSheet{ sheetFrames, sheetUseBlockSortPriority = True } binding page = foldl makeFrame page sheetFrames     where     makeFrame page MkFrame{ frameBox, frameBlocks }         | null frameBindings = page@@ -243,13 +359,68 @@         pageCleared   = clearArea frameBox page         pageReplaced  = replaceArea frameBox (concat frameBindings) pageCleared         frameBindings = -            [ fromJust result+            [ fst <$> fromJust result             | frameLabel <- LM.keys frameBlocks             , let result = LM.lookup frameLabel binding             , isJust result             ] --- Start with +-- Otherwise we inspect individual vars and apply them.+-- Also: For GROUP BY fields, leave things blank!+-- Key here is blockGroupBy.+makePage MkSheet{ sheetFrames } binding page = foldl makeFrame page sheetFrames+    where+    makeFrame page MkFrame{ frameBox, frameBlocks }+        | null frameBindings = page+        | otherwise          = pageReplaced+        where+        (pageReplaced, _) = foldl replacePage (page, frameBox) (concatMap (reverse . doGroupBy . reverse) frameBindings)+        frameBindings = +            [ (\(_, bound) -> (block, bound)) <$> fromJust result+            | (frameLabel, block) <- LM.toList frameBlocks+            , let result = LM.lookup frameLabel binding+            , isJust result+            ]++-- If we group by some fields, the second time the same field occurs,+-- _and_ if all fields to the left also matches, then do not bother to display it.+doGroupBy :: [(Block, LabelMap Bound)] -> [(Block, LabelMap Bound)]+doGroupBy [] = []+doGroupBy [x] = [x]+doGroupBy ((xb@MkBlock{ blockGroupBy }, xs):rest@((_, ys):_)) = (xb, xs'):doGroupBy rest+    where+    -- For each kv in xs:+    -- If the k is in blockGroupBy+    -- and v is in ys as v'+    -- and v == v'+    -- and all preceding fields also match+    -- then replace the v with empty+    xs' = LM.mapWithKey doCollapse xs+    doCollapse lbl val+        | lbl `elem` blockGroupBy+        , Just val' <- LM.lookup lbl ys+        , val == val'+        , preds <- takeWhile (/= lbl) blockGroupBy+        , map (`LM.lookup` xs) preds == map (`LM.lookup` ys) preds+        = S.empty+        | otherwise+        = val++replacePage :: (Page, Box) -> (Block, LabelMap Bound) -> (Page, Box)+replacePage (page, box@MkBox{ boxTop, boxLeft }) (MkBlock{ blockLines, blockFields }, bounds) = (page', box')+    where+    box' = box{ boxTop = boxTop + blockLines }+    page' = foldl replaceField page+        [ (fromJust rv, fieldBox)+        | (lbl, MkField{ fieldBox }) <- LM.toList blockFields+        , let rv = LM.lookup lbl bounds+        , isJust rv+        ]+    rowOffset = boxTop - 1+    colOffset = boxLeft - 1+    replaceField p (val, MkBox{ boxTop, boxLeft, boxBottom, boxRight})+        = fillArea (boxTop + rowOffset) (boxLeft + colOffset) (valueToArea val) p+ replaceArea :: Box -> [Area] -> Page -> Page replaceArea _ [] page = page replaceArea box@MkBox{ boxTop, boxLeft } (area:rest) page = replaceArea box' rest page'@@ -262,7 +433,7 @@     where     (before, rest)  = splitAt (boxTop-1) lns     (middle, after) = splitAt (boxBottom-boxTop+1) rest-    cleared         = map (fillLine boxLeft . ((,) whiteSpace)) middle+    cleared         = fillLine boxLeft . ((,) whiteSpace) <$> middle     whiteSpace      = S.replicate (boxRight-boxLeft+1) ' '  {-# INLINE fillArea #-}@@ -271,7 +442,7 @@     where     (before, rest)  = splitAt (row-1) lns     (middle, after) = splitAt (length areaLines) rest-    replaced        = map (fillLine col) (areaLines `zip` middle)+    replaced        = fillLine col <$> areaLines `zip` middle  {-# INLINE fillLine #-} fillLine :: Col -> (Value, Value) -> Value@@ -279,14 +450,14 @@     where     origLinePadded         | padLength <= 0    = origLine-        | otherwise         = origLine `S.append` S.replicate padLength '-' +        | 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 -doCapacity :: Sheet -> SheetResult -> [PageCapacity] -> [PageCapacity]-doCapacity MkSheet{ sheetFrames } MkSheetResult{ resultBlocks } pcs = pc:pcs+doCapacity :: Sheet -> [PageCapacity] -> SheetResult -> [PageCapacity]+doCapacity MkSheet{ sheetFrames } pcs MkSheetResult{ resultBlocks } = pc:pcs     where     pc              = map frameToSlot framesOccured     framesOccured   = filter (labelOccured . frameBlocks) sheetFrames@@ -297,21 +468,24 @@         , slotBlocks = LM.keys frameBlocks         } -doAttempt :: LabelMap [OrderBy Label] -> SheetResult -> FitAttempt -> FitAttempt-doAttempt orders MkSheetResult{ resultBlocks } att = att'+doAttempt :: LabelMap [OrderBy Label] -> FitAttempt -> SheetResult -> FitAttempt+doAttempt orders att MkSheetResult{ resultBlocks } = att'     where     att'            = LM.unionsWith mappend [att, LM.mapMaybeWithKey blockToData resultBlocks]-    blockToData lbl (MkBlockResult lms) = case areas of +    blockToData lbl (MkBlockResult lms) = case lms of          []              -> Nothing-        ((_, area):_)   -> Just MkBlockData+        ((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+            Just orderBys   -> \bound ->+                [ (`LM.lookup` bound) <$> orderBy+                | orderBy <- orderBys+                ]             Nothing         -> const []-        areas = [ (orderFrom vals, area) | (area, vals) <- lms ]+        areas = [ (orderFrom bound, area) | area@(_, bound) <- lms ]  areaRows :: Area -> Row areaRows (MkPage lns) = length lns@@ -325,17 +499,23 @@ valueToArea :: Value -> Area valueToArea val = MkPage [val] -sheetVariableFields :: Sheet -> LabelMap Field-sheetVariableFields MkSheet{ sheetFrames, sheetFields } = LM.unions filteredMaps+sheetVariableFields :: Sheet -> (LabelMap Field, LabelMap Field)+sheetVariableFields MkSheet{ sheetFrames, sheetFields } = (fieldMaps, LM.unions filteredMaps)     where-    filteredMaps = map (LM.filter (isJust . fieldVariable)) fieldMaps-    fieldMaps = LM.mapWithKey addVariable sheetFields : concatMap frameVariableFields sheetFrames+    fieldMaps = LM.mapWithKey addVariable sheetFields+    filteredMaps = LM.filter (fieldIsVariable . fieldVariable) <$> frameMaps+    frameMaps = concatMap frameVariableFields sheetFrames+    fieldIsVariable (Just VReplace{}) = False+    fieldIsVariable (Just VSubStr{}) = False+    fieldIsVariable Nothing = False+    fieldIsVariable _ = True     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)+        -- XXX - Special rule - blocks with GROUP BY is not filled in at this stage!+        blocks    = filter (null . blockGroupBy) $ LM.elems (frameBlocks frame)         rowOffset = boxTop frameBox - 1         colOffset = boxLeft frameBox - 1         blockVariableFields = fmap adjustField . blockFields@@ -349,10 +529,21 @@             }  sheetBlockOrderBys :: Sheet -> LabelMap [OrderBy Label]-sheetBlockOrderBys MkSheet{ sheetFrames } = LM.unions (map frameBlockOrderBys sheetFrames)+sheetBlockOrderBys = gatherForSheetBlock blockOrderBy++sheetBlockGroupBys :: Sheet -> LabelMap [Label]+sheetBlockGroupBys = gatherForSheetBlock blockGroupBy++sheetBlockFields :: Sheet -> LabelMap (LabelMap Field)+sheetBlockFields = gatherForSheetBlock blockFields++gatherForSheetBlock :: (Block -> a) -> Sheet -> LabelMap a+gatherForSheetBlock f MkSheet{ sheetFrames } = LM.unions (map doGather sheetFrames)     where-    frameBlockOrderBys MkFrame{ frameBlocks } = LM.fromList-        [ (lbl, order) | (lbl, order@(_:_)) <- LM.toList (fmap blockOrderBy frameBlocks) ]+    doGather MkFrame{ frameBlocks } = f <$> frameBlocks+    {-LM.fromList+        [ (lbl, vals) | (lbl, vals@(_:_)) <- LM.toList (f <$> 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@@ -381,7 +572,7 @@                 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+                newBinding   = LM.insertWith (++) b (snd <$> take consumed dataAreas) binding                 newSlot      = slot                     { slotSize   = slotSize - consumedSize                     , slotBlocks = bs

@@ -1,14 +1,16 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 Data.Monoid import Foreign.Ptr import Foreign.ForeignPtr import qualified Data.ByteString.Char8 as S  newtype Page = MkPage { pageLines :: [Value] }-    deriving (Show, Eq, Ord)+    deriving (Show, Eq, Ord, Monoid)  type Col = Int type Row = Int@@ -34,8 +36,9 @@     , sheetFields   :: !(LabelMap Field)     , sheetFrames   :: ![Frame]     , sheetGroupBy  :: ![Label]+    , sheetOrderBy  :: ![Label] --  , sheetPositioning          :: CharPos | GridPos---  , sheetUseBlockSortPriority :: Bool+    , sheetUseBlockSortPriority :: !Bool     }     deriving (Show, Eq, Ord) @@ -54,6 +57,8 @@     | VSum{ vScope :: !Scope, vLabel :: !Label }     | VCount{ vScope :: !Scope, vLabel :: !Label }     | VLabel{ vLabel :: !Label }+    | VSubStr{ vLabel :: !Label, vDrop :: !Int, vTake :: !Int }+    | VReplace{ vLabel :: !Label, vMatchReplace :: ![(Value, Value)]}     | VLiteral{ vValue :: !Value }     deriving (Show, Eq, Ord) @@ -99,9 +104,11 @@     , blockPatterns         :: !(LabelMap Pattern)     , blockFields           :: !(LabelMap Field)     , blockOrderBy          :: ![OrderBy Label]+    , blockGroupBy          :: ![Label]     , blockFilterBy         :: ![Filter] --  , blockRule             :: Rule --  , blockSortPriority     :: Priority+    , blockUsePriority      :: !Bool     }     deriving (Show, Eq, Ord) @@ -132,3 +139,18 @@     Just (num, _)   -> num     _               -> 0 +{-# INLINE matchSubstring #-}+matchSubstring :: Value -> Match -> (Maybe Int)+matchSubstring (PS x1 s1 l1) (MkMatch (PS x2 s2 l2))+    | l2 > l1   = Nothing+    | 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 Nothing else do+                        rv <- memcmp matchPtr (valuePtr `plusPtr` n) sz+                        if rv == 0 then return (Just n) else go (n+1)+                 in go 0