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
    -- 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)

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