diff --git a/PageIO.cabal b/PageIO.cabal --- a/PageIO.cabal +++ b/PageIO.cabal @@ -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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 () diff --git a/pio.hs b/pio.hs new file mode 100644 --- /dev/null +++ b/pio.hs @@ -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 + diff --git a/src/Text/PageIO.hs b/src/Text/PageIO.hs --- a/src/Text/PageIO.hs +++ b/src/Text/PageIO.hs @@ -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 diff --git a/src/Text/PageIO/Extract.hs b/src/Text/PageIO/Extract.hs --- a/src/Text/PageIO/Extract.hs +++ b/src/Text/PageIO/Extract.hs @@ -1,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 diff --git a/src/Text/PageIO/Index.hs b/src/Text/PageIO/Index.hs new file mode 100644 --- /dev/null +++ b/src/Text/PageIO/Index.hs @@ -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) +-} diff --git a/src/Text/PageIO/Infer.hs b/src/Text/PageIO/Infer.hs new file mode 100644 --- /dev/null +++ b/src/Text/PageIO/Infer.hs @@ -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" + diff --git a/src/Text/PageIO/LabelMap.hs b/src/Text/PageIO/LabelMap.hs --- a/src/Text/PageIO/LabelMap.hs +++ b/src/Text/PageIO/LabelMap.hs @@ -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 diff --git a/src/Text/PageIO/Parser.hs b/src/Text/PageIO/Parser.hs --- a/src/Text/PageIO/Parser.hs +++ b/src/Text/PageIO/Parser.hs @@ -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 diff --git a/src/Text/PageIO/Transform.hs b/src/Text/PageIO/Transform.hs --- a/src/Text/PageIO/Transform.hs +++ b/src/Text/PageIO/Transform.hs @@ -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 diff --git a/src/Text/PageIO/Types.hs b/src/Text/PageIO/Types.hs --- a/src/Text/PageIO/Types.hs +++ b/src/Text/PageIO/Types.hs @@ -1,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