module Text.PageIO.Transform where
import Data.Maybe
import Data.Monoid
import Data.Function (on)
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, Bound(..), crop, fieldLen, formatDotted)
data Doc = MkDoc
{ docMeta :: !SheetResult
, docContent :: !L.ByteString
}
deriving (Show, Eq, Ord)
type ValueMap = LabelMap [Value]
data AppliedVariable = MkAppliedVariable
{ avRow :: !Row
, avCol :: !Col
, avValue :: !Value
}
deriving (Show, Eq, Ord)
data Slot = MkSlot
{ slotSize :: !Row
, slotBlocks :: ![Label]
}
deriving (Eq, Ord, Show)
type Ordered a = ([OrderBy (Maybe Value)], a)
data BlockData = MkBlockData
{ dataSize :: !Row
, dataAreas :: ![Ordered FieldBinding]
}
deriving (Eq, Ord, Show)
instance Monoid BlockData where
mempty = MkBlockData (error "impossible") []
mappend x y = x{ dataAreas = dataAreas x ++ dataAreas y }
mconcat [] = mempty
mconcat xs = MkBlockData
{ dataSize = dataSize (head xs)
, dataAreas = concatMap dataAreas xs
}
type PageCapacity = [Slot]
type FitAttempt = LabelMap BlockData
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
[] -> [map snd resultsIn]
lbls -> map (map snd) $ groupBy ((==) `on` docKeys) $ sortBy (compare `on` docKeys) resultsIn
where
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)
where
meta = mconcat results
results = map fst xs
pages = map snd xs
transformPages :: Sheet -> [Page] -> Sheet -> [Page] -> [Doc]
transformPages sheetIn pagesIn sheetOut pagesOut = map (makeDoc sheetOut) docGroupsOut
where
bindingsOut = concatMap (bindDoc sheetOut pagesOut) docGroupsIn
docGroupsOut = case sheetGroupBy sheetOut of
[] -> [bindingsOut]
lbls -> groupBy ((==) `on` docKeys)
$ sortBy (compare `on` docKeys) bindingsOut
where
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 (vm, _) = map (`LM.lookup` vm) lbls
where
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 pages)
where
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
packPages ps = unpages [ L.unlines [ L.fromChunks [l] | l <- pageLines p ] | p <- ps ]
where
unpages :: [L.ByteString] -> L.ByteString
unpages [] = L.empty
unpages ss = (L.concat $ intersperse nl ss) `L.append` nl
where nl = L.pack "\x0C\n"
data DocBinding = MkDocBinding
{ docValueMap :: !ValueMap
, docResult :: !SheetResult
, docPage :: !Page
, docBinding :: !PageBinding
}
deriving (Show, Eq, Ord)
bindDoc :: Sheet -> [Page] -> [SheetResult] -> [DocBinding]
bindDoc sheetOut pagesOut resultsIn = case find (\(x, _, _) -> isJust x) pageBindings of
Just (Just bindings, boundPages, boundResults) ->
[ MkDocBinding (makeValueMap r) r p b
| r <- boundResults
| b <- bindings
| p <- boundPages
]
_ -> []
where
resultsOut = fromMaybe (error "Roundtrip failed!") . extractPage sheetOut
<$> pagesOut
orders = sheetBlockOrderBys sheetOut
capacity = foldl (doCapacity sheetOut) [] resultsOut
attempt = foldl (doAttempt orders) mempty resultsIn
capacityTails = repeatTails capacity
pageTails = repeatTails pagesOut
resultTails = repeatTails resultsIn
pageBindings =
[ (tryFit pc groupedAttempt, pages', results')
| pc <- capacityTails
| pages' <- pageTails
| results' <- resultTails
]
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 ]
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)
doGroupArea :: [Label] -> LabelMap Field -> [Ordered FieldBinding] -> [Ordered FieldBinding]
doGroupArea groups fields xs = map (doGroupRows fields) $ groupBy ((==) `on` areaKeys) xs
where
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)
repeatTails :: [a] -> [[a]]
repeatTails [] = []
repeatTails orig@(x:xs) = reverse (tails xs) ++ map (++ orig) infinitePrefixes
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
fillVariables :: Sheet -> [SheetResult] -> [Page] -> [Page]
fillVariables sheet results pages =
[ fillPageVariables appliedVars p
| p <- pages
| appliedVars <- applyVariable <$> [1..] `zip` valueMaps
]
where
(fieldVars, frameVars) = sheetVariableFields sheet
valueMaps = makeValueMap <$>
[ MkSheetResult rf nr
| MkSheetResult rf _ <- results
| MkSheetResult _ nr <- newResults
]
docVals = LM.unionsWith (++) valueMaps
newResults = fromMaybe err . extractPage sheet <$> pages
err = error "Roundtrip failed during variable fill!"
applyVariable :: (Int, ValueMap) -> LabelMap AppliedVariable
applyVariable (pageNum, pageVals) =
LM.mapMaybeWithKey (applyOneVariable False) fieldVars
`LM.union`
LM.mapMaybeWithKey (applyOneVariable True) frameVars
where
applyOneVariable :: Bool -> Label -> Field -> Maybe AppliedVariable
applyOneVariable isInFrame lbl fld@MkField{ fieldBox, fieldVariable }
| Just var <- fieldVariable
, if isInFrame then LM.member lbl pageVals else True
= Just MkAppliedVariable
{ avRow = boxTop fieldBox
, avCol = boxLeft fieldBox
, avValue = getVar var
}
| otherwise = Nothing
where
len = fieldLen fld
valOf :: Scope -> Label -> [Value]
valOf scope lbl = fromMaybe [] $ LM.lookup lbl vals
where
vals = case scope of
SDoc -> docVals
SPage -> pageVals
getVar VPage = formatInt len pageNum
getVar (VSum scope label) = case fieldFormat fld of
FNumeric 2 -> (formatDotted (len6) . 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) ' '
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 = (:[]) <$> resultFields
blockMaps :: [ValueMap]
blockMaps = makeBlockValueMap <$> LM.elems resultBlocks
makeBlockValueMap :: BlockResult -> ValueMap
makeBlockValueMap (MkBlockResult avs) = LM.unionsWith (++) maps
where
maps :: [LabelMap [Value]]
maps = [ (:[]) <$> bound | (_, bound) <- avs ]
makePage :: Sheet -> PageBinding -> Page -> Page
makePage MkSheet{ sheetFrames, sheetUseBlockSortPriority = True } binding page = foldl makeFrame page sheetFrames
where
makeFrame page MkFrame{ frameBox, frameBlocks }
| null frameBindings = page
| otherwise = pageReplaced
where
pageCleared = clearArea frameBox page
pageReplaced = replaceArea frameBox (concat frameBindings) pageCleared
frameBindings =
[ fst <$> fromJust result
| frameLabel <- LM.keys frameBlocks
, let result = LM.lookup frameLabel binding
, isJust result
]
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
]
doGroupBy :: [(Block, LabelMap Bound)] -> [(Block, LabelMap Bound)]
doGroupBy [] = []
doGroupBy [x] = [x]
doGroupBy ((xb@MkBlock{ blockGroupBy }, xs):rest@((_, ys):_)) = (xb, xs'):doGroupBy rest
where
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'
where
box' = box{ boxTop = boxTop + areaRows area}
page' = fillArea boxTop boxLeft area page
clearArea :: Box -> Page -> Page
clearArea MkBox{ boxTop, boxLeft, boxBottom, boxRight } (MkPage lns) = MkPage $ before ++ cleared ++ after
where
(before, rest) = splitAt (boxTop1) lns
(middle, after) = splitAt (boxBottomboxTop+1) rest
cleared = fillLine boxLeft . ((,) whiteSpace) <$> middle
whiteSpace = S.replicate (boxRightboxLeft+1) ' '
fillArea :: Row -> Col -> Area -> Page -> Page
fillArea row col (MkPage areaLines) (MkPage lns) = MkPage $ before ++ replaced ++ after
where
(before, rest) = splitAt (row1) lns
(middle, after) = splitAt (length areaLines) rest
replaced = fillLine col <$> areaLines `zip` middle
fillLine :: Col -> (Value, Value) -> Value
fillLine col (areaLine, origLine) = S.concat [before, areaLine, after]
where
origLinePadded
| padLength <= 0 = origLine
| otherwise = origLine `S.append` S.replicate padLength ' '
padLength = (col + areaLength 1) S.length origLine
(before, rest) = S.splitAt (col1) origLinePadded
after = S.drop areaLength rest
areaLength = S.length areaLine
doCapacity :: Sheet -> [PageCapacity] -> SheetResult -> [PageCapacity]
doCapacity MkSheet{ sheetFrames } pcs MkSheetResult{ resultBlocks } = pc:pcs
where
pc = map frameToSlot framesOccured
framesOccured = filter (labelOccured . frameBlocks) sheetFrames
labelOccured lm = any (`LM.member` lm) resultLabels
resultLabels = LM.keys resultBlocks
frameToSlot MkFrame{ frameBox, frameBlocks } = MkSlot
{ slotSize = boxBottom frameBox boxTop frameBox + 1
, slotBlocks = LM.keys frameBlocks
}
doAttempt :: LabelMap [OrderBy Label] -> FitAttempt -> SheetResult -> FitAttempt
doAttempt orders att MkSheetResult{ resultBlocks } = att'
where
att' = LM.unionsWith mappend [att, LM.mapMaybeWithKey blockToData resultBlocks]
blockToData lbl (MkBlockResult lms) = case lms of
[] -> Nothing
((area, _):_) -> Just MkBlockData
{ dataSize = areaRows area
, dataAreas = areas
}
where
orderFrom = case LM.lookup lbl orders of
Just orderBys -> \bound ->
[ (`LM.lookup` bound) <$> orderBy
| orderBy <- orderBys
]
Nothing -> const []
areas = [ (orderFrom bound, area) | area@(_, bound) <- lms ]
areaRows :: Area -> Row
areaRows (MkPage lns) = length lns
fillPageVariables :: LabelMap AppliedVariable -> Page -> Page
fillPageVariables avs page = foldl fillOneVar page (LM.elems avs)
where
fillOneVar page MkAppliedVariable{ avRow, avCol, avValue }
= fillArea avRow avCol (valueToArea avValue) page
valueToArea :: Value -> Area
valueToArea val = MkPage [val]
sheetVariableFields :: Sheet -> (LabelMap Field, LabelMap Field)
sheetVariableFields MkSheet{ sheetFrames, sheetFields } = (fieldMaps, LM.unions filteredMaps)
where
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 = filter (null . blockGroupBy) $ LM.elems (frameBlocks frame)
rowOffset = boxTop frameBox 1
colOffset = boxLeft frameBox 1
blockVariableFields = fmap adjustField . blockFields
adjustField field@MkField{ fieldBox = MkBox{ boxTop, boxLeft, boxBottom, boxRight } } = field
{ fieldBox = MkBox
{ boxTop = boxTop + rowOffset
, boxLeft = boxLeft + colOffset
, boxBottom = boxBottom + rowOffset
, boxRight = boxRight + colOffset
}
}
sheetBlockOrderBys :: Sheet -> LabelMap [OrderBy Label]
sheetBlockOrderBys = 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
doGather MkFrame{ frameBlocks } = f <$> frameBlocks
tryFit :: [PageCapacity] -> FitAttempt -> Maybe [PageBinding]
tryFit pcs att = go pcs ([], att)
where
go [] (bindings, att)
| all (null . dataAreas) (LM.elems att) = Just (reverse bindings)
| otherwise = Nothing
go (p:ps) (bindings, att) = go ps ((bnd:bindings), att')
where
(bnd, att') = fitOnePage p (mempty, att)
fitOnePage :: [Slot] -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)
fitOnePage [] x = x
fitOnePage (s:ss) x = fitOnePage ss $ fitOneSlot s x
fitOneSlot :: Slot -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)
fitOneSlot slot@MkSlot{ slotSize, slotBlocks } x@(binding, att) = case slotBlocks of
[] -> x
(b:bs) -> case LM.lookup b att of
Just dat@MkBlockData{ dataSize, dataAreas } ->
let consumed = min (length dataAreas) (slotSize `div` dataSize)
consumedSize = consumed * dataSize
newData = dat{ dataAreas = drop consumed dataAreas }
newAttempt = LM.insert b newData att
newBinding = LM.insertWith (++) b (snd <$> take consumed dataAreas) binding
newSlot = slot
{ slotSize = slotSize consumedSize
, slotBlocks = bs
}
in fitOneSlot newSlot (newBinding, newAttempt)
_ -> fitOneSlot slot{ slotBlocks = bs } x