module Text.PageIO.Parser where
import Text.Parsec
import Text.Parsec.ByteString
import Data.ByteString.Lazy.Char8 (pack, ByteString, toChunks)
import Text.PageIO.Types
import Control.Monad (liftM3, liftM4)
import Numeric (readDec)
import Codec.Text.IConv
import qualified Data.ByteString.Char8 as S
import qualified Text.PageIO.LabelMap as LM
readSheet :: String -> IO (Either ParseError Sheet)
readSheet = parseFromFile sheet
parseMaybe :: Parser a -> Parser (Maybe a)
parseMaybe r = fmap Just r <|> return Nothing
maybeFieldVariable :: Parser (Maybe Variable)
maybeFieldVariable = parseMaybe $ do
char '$'
choice
[ sym "PAGE" >> return VPage
, literalVariable
, functionVariable
]
literalVariable :: Parser Variable
literalVariable = do
s <- literalStr
ret $ VLiteral s
functionVariable :: Parser Variable
functionVariable = do
fun <- choice
[ sym "SUM(" >> return VSum
, sym "COUNT(" >> return VCount
]
scope <- choice
[ sym "page." >> return SPage
, sym "doc." >> return SDoc
, return SPage
]
fld <- many1 $ noneOf ".) "
sym ")"
return $ fun scope (toLabel fld)
maybeFieldFormat :: Parser (Maybe FieldFormat)
maybeFieldFormat = parseMaybe $ do
sym "Format"
choice
[ sym "\"NZ ZZZ ZZ9,99\"" >> return (FNumeric 0)
, sym "\"Nk= d=.\"" >> return (FNumeric 0)
, sym "\"NZ,ZZZ,ZZZ,ZZ#.##\"" >> return (FNumeric 2)
]
maybeFilters :: Parser (Maybe [Filter])
maybeFilters = parseMaybe $ do
sym "WHERE"
parseFilter `sepEndBy` sym "AND"
parseFilter :: Parser Filter
parseFilter = liftM3 MkFilter parseLabel operator (fmap mkMatch quotedValue)
operator :: Parser Operator
operator = choice
[ sym "NOT" >> fmap ONot operator
, sym "CONTAINS" >> return OContains
, sym "STARTSWITH" >> return OStartsWith
, sym "ENDSWITH" >> return OEndsWith
, sym "==" >> return OEq
, sym "=" >> return OEq
, sym "!=" >> return (ONot OEq)
, sym "<>" >> return (ONot OEq)
]
maybeOrderBys :: Parser (Maybe [OrderBy Label])
maybeOrderBys = parseMaybe $ do
sym "ORDER"
sym "BY"
orders <- (`sepEndBy` sym ",") $ do
lbl <- parseLabel
choice
[ sym "DESC" >> return (DDescending lbl)
, optional (sym "ASC") >> return (DAscending lbl)
]
ret $ orders
maybeBy :: String -> Parser (Maybe [Label])
maybeBy by = parseMaybe $ do
sym by
sym "BY"
lbls <- parseLabel `sepEndBy` sym ","
ret $ lbls
maybeRule :: Parser (Maybe a) -> Parser (Maybe a)
maybeRule p = (<|> return Nothing) $ do
between (sym "Rule" >> sym "\"") (sym "\";") p
parseLabel :: Parser Label
parseLabel = do
s <- many (noneOf "\", ")
ret $ toLabel s
sheet :: Parser Sheet
sheet = do
manyTill anyChar (sym "UseCharPos" <|> sym "UseGridPos")
sym "Sheet"
right <- num
bottom <- num
optional (sym "UsePriority")
pats <- many pattern
grp <- maybeRule $ maybeBy "GROUP"
flds <- many field
frames <- many frame
sym "End"
ret $ MkSheet
{ sheetBox = MkBox
{ boxLeft = 1
, boxTop = 1
, boxRight = right
, boxBottom = bottom
}
, sheetPatterns = LM.fromList
[ (lbl, pat{ patternBox = box{ boxRight = right } })
| (lbl, pat) <- pats, let box = patternBox pat
]
, sheetFields = LM.fromList flds
, sheetFrames = (`fmap` frames) $ \frm -> frm
{ frameBlocks = (`fmap` frameBlocks frm) $ \blk -> blk
{ blockPatterns = (`fmap` blockPatterns blk) $ \pat -> pat
{ patternBox = (patternBox pat){ boxRight = right }
}
}
}
, sheetGroupBy = maybe [] id grp
}
sym :: String -> Parser ()
sym s = try (string s) >> sp
ret :: a -> Parser a
ret x = sp >> return x
sp :: Parser ()
sp = skipMany (space <|> (try (string "//") >> skipMany (noneOf ['\n']) >> anyChar))
num :: Parser Int
num = do
digits <- many1 digit
ret $ fst (head $ readDec digits)
pattern :: Parser (Label, Pattern)
pattern = do
sym "Match"
lbl <- labelStr
left <- num
top <- num
mat <- matchStr
wc <- (sym "UseWildCards" >> return True) <|> return False
retLabel lbl MkPattern
{ patternBox = MkBox
{ boxLeft = left
, boxTop = top
, boxRight = error "To be updated later"
, boxBottom = top
}
, patternMatch = mat
, patternUseWildcards = wc
}
field :: Parser (Label, Field)
field = do
sym "Field"
lbl <- labelStr
box <- boxNumbers
var <- maybeFieldVariable
fmt <- maybeFieldFormat
char ';'
retLabel lbl MkField
{ fieldBox = box
, fieldKeepSpaces = True
, fieldVariable = var
, fieldFormat = maybe FGeneral id fmt
}
boxNumbers :: Parser Box
boxNumbers = liftM4 MkBox num num num num
frame :: Parser Frame
frame = do
sym "Frame"
box <- boxNumbers
blocks <- many block
sym "End"
ret $ MkFrame
{ frameBox = box
, frameBlocks = LM.fromList blocks
}
retLabel :: Label -> a -> Parser (Label, a)
retLabel l x = ret (l, x)
block :: Parser (Label, Block)
block = do
sym "Block"
lbl <- labelStr
optional (sym "UsePriority")
sym "Lines"
lns <- num
pats <- many pattern
(filters, orders) <- fmap (maybe (Nothing, Nothing) id) . maybeRule $ do
filters <- maybeFilters
orders <- maybeOrderBys
return (Just (filters, orders))
flds <- many field
sym "End"
retLabel lbl MkBlock
{ blockLines = lns
, blockPatterns = LM.fromList
[ (l, pat{ patternBox = adjustBox box })
| (l, pat) <- pats, let box = patternBox pat
]
, blockFields = LM.fromList
[ (l, fld{ fieldBox = adjustBox box })
| (l, fld) <- flds, let box = fieldBox fld
]
, blockOrderBy = maybe [] id orders
, blockFilterBy = maybe [] id filters
}
where
adjustBox (MkBox l t r b) = MkBox (l+1) (t+1) (r+1) (b+1)
literalStr :: Parser Value
literalStr = do
beginQuote <- oneOf "\"'"
s <- many (noneOf [beginQuote])
char beginQuote
ret . packLBS . convert "UTF-8" "CP950" $ pack s
matchStr :: Parser Match
matchStr = fmap (mkMatch . packLBS . convert "UTF-8" "CP950") str
mkMatch :: Value -> Match
mkMatch s = MkMatch $ S.init (s `S.append` S.singleton '\0')
packLBS :: ByteString -> S.ByteString
packLBS = S.concat . toChunks
labelStr :: Parser Label
labelStr = fmap (toLabel . packLBS) str
str :: Parser ByteString
str = do
char '"'
s <- many (noneOf ['"'])
char '"'
ret $ pack s
quotedValue :: Parser Value
quotedValue = do
beginQuote <- oneOf "\"'"
s <- many (noneOf [beginQuote])
char beginQuote
ret $ S.pack s