module Text.PageIO.Parser where
import Codec.Text.IConv
import Control.Applicative
import Data.ByteString.Lazy.Char8 (pack, ByteString, toChunks)
import Data.Maybe
import Data.ParserCombinators.Attoparsec.Char8
import Numeric (readDec)
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 = 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 p = Just <$> p
<|> return Nothing
maybeFieldVariable :: Parser (Maybe Variable)
maybeFieldVariable = parseMaybe $
char '$'
*> choice
[ VLabel <$> (char '$' *> bareLabel)
, VPage <$ sym "PAGE"
, literalVariable
, functionVariable
, substrVariable
, replaceVariable
]
literalVariable :: Parser Variable
literalVariable = r$ VLiteral <$> literalStr
functionVariable :: Parser Variable
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 = r$ toLabel <$> many1 (noneOf ",.;) ")
maybeFieldFormat :: Parser (Maybe FieldFormat)
maybeFieldFormat = parseMaybe $
sym "Format"
*> 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 $
sym "WHERE" *>
parseFilter `sepEndBy` sym "AND"
parseFilter :: Parser Filter
parseFilter = liftA3 MkFilter
parseLabel
operator
(mkMatch <$> quotedValue)
operator :: Parser Operator
operator = choice
[ 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 = 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 = r$ parseMaybe $
sym by *>
sym "BY" *>
commaSep parseLabel
maybeRule :: Parser (Maybe a) -> Parser (Maybe a)
maybeRule p =
between (sym "Rule" *> sym "\"") (sym "\";") p
<|> return Nothing
parseLabel :: Parser Label
parseLabel = r$ toLabel <$> many (noneOf "\", ")
r :: Parser a -> Parser a
r = (<* sp)
sheet :: Parser Sheet
sheet = r$ between (sym "Event") (sym "End") $ do
name <- labelStr
manyTill anyChar (sym "UseCharPos" <|> sym "UseGridPos")
sym "Sheet"
right <- num
bottom <- num
pri <- (True <$ sym "UsePriority") <|> return False
pats <- many pattern
(grp, odr) <- (fromMaybe (Nothing, Nothing) <$>) . maybeRule $
Just <$> ((,) <$> maybeBy "GROUP" <*> maybeBy "ORDER")
flds <- many field
frames <- many frame
return $ MkSheet
{ sheetName = name
, 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 = frames <$$> \frm -> frm
{ frameBlocks = frameBlocks frm <$$> \blk -> blk
{ blockPatterns = blockPatterns blk <$$> \pat -> pat
{ patternBox = (patternBox pat){ boxRight = right }
}
}
}
, sheetOrderBy = fromMaybe (fromMaybe [] grp) odr
, sheetGroupBy = fromMaybe [] grp
, sheetUseBlockSortPriority = pri
}
sym :: String -> Parser ()
sym s = try (string (pack s)) *> sp
sp :: Parser ()
sp = skipMany (space <|> (try (string (pack "//")) *> skipMany (notChar '\n') *> anyChar))
num :: Parser Int
num = r$ fst . head . readDec <$> many1 digit
pattern :: Parser (Label, Pattern)
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
, boxRight = error "To be updated later"
, boxBottom = top
}
, patternMatch = mat
, patternUseWildcards = wc
}
field :: Parser (Label, Field)
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 = fromMaybe FGeneral fmt
}
boxNumbers :: Parser Box
boxNumbers = liftA4 MkBox num num num num
frame :: Parser Frame
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 = (l, x) <$ sp
block :: Parser (Label, Block)
block = between (sym "Block") (sym "End") $ do
lbl <- labelStr
pri <- (True <$ sym "UsePriority") <|> return False
sym "Lines"
lns <- num
pats <- many pattern
(filters, groups, orders) <- (fromMaybe (Nothing, Nothing, Nothing) <$>) . maybeRule $
Just <$> ((,,) <$> maybeFilters <*> maybeBy "GROUP" <*> maybeOrderBys)
flds <- many field
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 = fromMaybe (DAscending <$> fromMaybe [] groups) orders
, blockGroupBy = fromMaybe [] groups
, blockFilterBy = fromMaybe [] filters
, blockUsePriority = pri
}
where
adjustBox (MkBox left top right bottom) = MkBox (left+1) (top+1) (right+1) (bottom+1)
literalStr :: Parser Value
literalStr = r$ do
beginQuote <- oneOf "\"'"
packLBS . convert "UTF-8" "CP950" . pack
<$> many (noneOf [beginQuote])
<* char beginQuote
matchStr :: Parser Match
matchStr = 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 = toLabel . packLBS <$> str
str :: Parser ByteString
str = pack <$> (char '"' *> many (noneOf ['"']) <* char '"' <* sp)
quotedValue :: Parser Value
quotedValue = r$ do
beginQuote <- oneOf "\"'"
S.pack <$> many (noneOf [beginQuote])
<* char beginQuote
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
between :: Parser a -> Parser b -> Parser c -> Parser c
between open close p = open *> p <* close
oneOf :: [Char] -> Parser Char
oneOf = satisfy . flip elem
noneOf :: [Char] -> Parser Char
noneOf = satisfy . flip notElem