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
    -- We adjust box because StreamServe counts in-block coordinates from (0,0).
    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

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